|
 |
Les Médias
Joue un son Wav
Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpzSoundName As String, ByVal uFlags As Long) As Long
Sub Musique()
If Application.CanPlaySounds Then
Call sndPlaySound32("D:\Sons\Vinyl\creedenc.wav", 0)
Changer le chemin...("D:\.....", 0)
End If
End Sub
Ouvre et ferme le lecteur de CD
Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long)
Sub Ouvre()
mciSendStringA "Set CDAudio Door Open", 0&, 0, 0
End Sub
Sub Ferme()
mciSendStringA "Set CDAudio Door Closed", 0&, 0, 0
End Sub
Teste s'il existe un lecteur de CD
Private Declare Function GetDriveTypeA Lib "Kernel32" _
(ByVal nDrive As String) As Long
Sub TestCD()
Dim I As Integer
For I = 65 To 91
If GetDriveTypeA(Chr$(I) & ":\") = 5 Then Exit For
Next I
If I = 92 Then MsgBox "Aucun lecteur de CD-ROM détecté." _
Else MsgBox "Lecteur détecté sur " & Chr$(I) & ":"
End Sub
JUST FOR FUN...sur une macro de Tommy Flynn
Sub ShowStars()
Cells.Select
Selection.Interior.ColorIndex = 1
Range("A1").Select
Randomize
StarWidth = 35
StarHeight = 35
For i = 1 To 10
TopPos = Rnd() * (ActiveWindow.UsableHeight - StarHeight)
LeftPos = Rnd() * (ActiveWindow.UsableWidth - StarWidth)
Set NewStar = ActiveSheet.Shapes.AddShape _
(msoShape4pointStar, LeftPos, TopPos, StarWidth, StarHeight)
NewStar.Fill.ForeColor.SchemeColor = Int(Rnd() * 56)
Application.Wait Now + TimeValue("00:00:01")
DoEvents
Next i
Application.Wait Now + TimeValue("00:00:02")
Set myShapes = Worksheets(1).Shapes
For Each shp In myShapes
If Left(shp.Name, 9) = "AutoShape" Then
shp.Delete
Application.Wait Now + TimeValue("00:00:01")
End If
Next
Cells.Select
Selection.Interior.ColorIndex = 2
Range("A1").Select
End Sub
Joue un son MP3.
MS et Laurent Daures
Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByValuReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As _
String, ByVal cchBuffer As Long) As Long
Sub LanceMP3()
X = ThisWorkbook.Path
joueMP3 (X & "\monfichier.mp3")
End Sub
Public Sub joueMP3(ByVal Mp3 As String)
Dim Tmp As Long, Tmp2 As String
'Screen.MousePointer = vbHourglass
Tmp2 = NomCourt(Mp3)
Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&)
Tmp = mciSendString("open " & Tmp2 & " type MPEGVideo alias MP3_Device", _
vbNullString, 0&, 0&)
If Tmp = 0 Then
Tmp = mciSendString("play Mp3_Device", vbNullString, 0&, 0&)
If Tmp <> 0 Then
Screen.MousePointer = 0
MsgBox "Incapable de jouer ce Mp3"
'Else
' Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&)
End If
Else
'Screen.MousePointer = 0
MsgBox "Incapable de jouer ce Mp3"
End If
'Screen.MousePointer = 0
End Sub
Public Sub StopMP3()
Dim Tmp As Long
Tmp = mciSendString("close MP3_Device", vbNullString, 0&, 0&)
End Sub
Private Function NomCourt(ByVal Fichier As String) As String
Dim Tmp As String * 255, Tmp2 As Byte
Tmp2 = GetShortPathName(Fichier, Tmp, Len(Tmp))
If Tmp2 > 0 Then
NomCourt = Left(Tmp, Tmp2)
End If
End Function
Sélectionne un fichier image et l'insère dans la feuille active
Sub insertImg()
Dim fichImg
fichImg = Application.GetOpenFilename("Fichier image(*.gif;*.jpg;*.bmp),*.gif;*.jpg;*.bmp" _
, , "Choix de l'image", , False) 'false selection simple
If fichImg = False Then Exit Sub
ActiveSheet.Pictures.Insert(fichImg).Select
End Sub
Un trombinoscope via les commentaires
Dans les cellules A1:A10 entrez une liste de noms correspondant à des portraits (par ex.)
Cette liste de noms doit correspondre à une liste de fichiers "JPG" situés dans le même dossier que votre classeur.
Sélectionnez la zone A1:A10 et executez la macro "imgComment".
Au passage de la souris sur ces cellules les portraits s'afficheront dans les commentaires de cellules
Sub imgComment()
Dim nom$
On Error Resume Next
For Each C In Selection
nom = C.Value
With C
.AddComment
.Comment.Shape.Fill.UserPicture ActiveWorkbook.Path & "\" & nom & ".jpg"
End With
Next
End Sub
Insère une image dans une cellule
Une image est insérée en C10
Le nom de l'image est recuperée dans la cellule B10
(nom = Selection.Offset(0, -1).Value) ex : photo1 sans l'extension.
(fichimg = ActiveWorkbook.Path & "\" & nom & ".jpg")
L'image est dans le même dossier que le classeur
(ActiveWorkbook.Path)
La largeur de l'image correspondra à la largeur de la cellule C10.
(With ActiveWindow , y = .Selection.Width , End With)
(Selection.ShapeRange.Width = y)
Sub InserImage()
Dim nom$
Dim fichimg$
[C10].Select
With ActiveWindow
y = .Selection.Width
End With
On Error Resume Next
nom = Selection.Offset(0, -1).Value
fichimg = ActiveWorkbook.Path & "\" & nom & ".jpg"
ActiveSheet.Pictures.Insert(fichimg).Select
Selection.ShapeRange.Width = y
End Sub
[top]
|
