EXCEL & le MULTIMEDIA

dans une formule à l'aide de la fonction de feuille de calcul Fonction.Appelante

cette fonction n'est pas disponible dans les versions 2000 et sup d'Excel
(vendredi 14/04/2000, by L.L., Re: Problème : Avec la Fonction " Si ")
=SI(A1=1;FONCTION.APPELANTE("winmm.dll";"sndPlaySoundA";"JCJ"; "C:\Windows\Media\Chord.wav";1))

par vba, en utilisant la méthode Verb

pour réaliser cela, insérer un fichier son via la commande insertion d'objets du menu insertion.
dans l'exemple ci-dessous, l'objet son inséré a le nom "Objet 1".
marche pour tout type de son.

ActiveSheet.Shapes("Objet 1").Select : Selection.Verb

par vba, en utilisant la fonction mciexecute

Sub PlayMIDI() 'par Philippe L.)
If Application.CanPlaySounds Then
mciExecute "play " & "C:\Windows\Media\Passport.mid"
Else
MsgBox "Sound is not supported on your system !, " & vbCrLf _
& "but anyway, the code is processing", , "Désolé"
Exit Sub
End If
End Sub

par vba, en utilisant la fonction api sndPlaySound

Private Declare function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As long) As long

Dim ret
ret = sndPlaySound("C:\windows\media\chimes.wav", 0)

par vba, en utilisant la fonction api PlaySound

Private Declare function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As long, ByVal dwFlags As long) As long

Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_FILENAME = &H20000

Sub PlayWAV()
WAVFile = "C:\WINDOWS\MEDIA\Jungle Maximize.wav"
Call PlaySound(WAVFile, 0&, SND_ASYNC Or SND_FILENAME)
End Sub

Option Explicit

Declare function MessageBeep Lib "USER32" (ByVal wType As long) As long
Const MB_ICH = &H10&
Const MB_IC = &H10&
Const MB_IQ = &H20&
Const MB_IE = &H30&
Const MB_IA = &H40&
Const MB_IINFO = &H40&

function FNCsound()
For INTFilaActual = 1 To 3
MessageBeep MB_ICH
MessageBeep MB_IQ
MessageBeep MB_IE
MessageBeep MB_IA
MessageBeep MB_IINFO
Next
end function

Declare Sub mciSendStringA Lib "winmm.dll" (ByVal lpstrCommand As String, _
ByVal lpstrReturnString As Any, ByVal uReturnLength As long, _
ByVal hwndCallback As long)

Sub OpenCDTray()
mciSendStringA "Set CDAudio door Open", 0&, 0, 0
End Sub

Sub CloseCDTray()
mciSendStringA "Set CDAudio door Closed", 0&, 0, 0
End Sub

Sub Test()
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

'Numéroteur
Private Declare Function tapiRequestMakeCall Lib "tapi32.dll" (ByVal DestAddress As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long

Private Sub Command1_Click()
Call tapiRequestMakeCall("123-4567", "Jean-Paul Belmondo", "Bebel", "")
End Sub

Sub Numéroteur()
leNum = ActiveCell.Value: Appname = "Dialer": AppFile = "Dialer.exe"
On Error Resume Next
AppActivate (Appname)
If Err <> 0 Then
Err = 0
TaskID = Shell(AppFile, 1)
If Err <> 0 Then MsgBox "Can't start " & AppFile
End If
Application.SendKeys "%n" & leNum, True
Application.SendKeys "%d"
End Sub

Créer des listes d'autocomplétion de mots :

J'entends par là la liste qui apparaît sous l'éditeur pour vous aider à compléter votre texte.

Je ne l'ai pas encore fait, mais j'avais sollicité de l'aide à ce sujet en 1999 :

In order for you to have this, you must create a CLASS module for each "object" that contains the properties and methods you want to have in the
list.

In very general terms, you insert a class module in a project, and in its Initialize event load the information you want to pick up from "outside".
Using Property Let and Property Get you make it available to other projects (Let allows "write" and Get allows "read").

Actually, you need this in the SAME project but different module to declare an object variable for the class: Dim oData as C_Data, for it to work easily.

Then you "instantiate" the variable (which the stuff in the CLass_Initialize procedure) : Set oData = New c_Data

From then on, you get the dropdown list when you type oData.

At some point you need to: Set oData = Nothing in order to free up system resources.

If you need to access the class from other projects, you must make sure you have a REFERENCE to the project containing the class in the project in which you want to use it. (Tools/References)

Il s'agit là de navigation au sein des feuilles et cellules d'un classeur

Naviguer vers la page suivante ou précédente
Cela peut se faire avec deux macros associés à des boutons (de barre d'outils par exemple) "Suivanté et "Précédent".

Sub GoToPrevSheet()
If ActiveSheet.Index = 1 Then
sheets(sheets.Count).Activate
Else
ActiveSheet.Previous.Activate
End If
End Sub

Sub GoToNextSheet()
If ActiveSheet.Index = sheets.Count Then
sheets(1).Activate
Else
ActiveSheet.Next.Activate
End If
End Sub

Naviguer vers les précédentes cellules sélectionnées, avec la propriété PreviousSelections

Excel stocke les cinq dernières cellules précédemment sélectionnées en supposant qu'Excel se soit déplacé vers ces cellules grâce à la méthode GOTO du langage Visual Basic For Applications. Pour que cela fonctionne, vous pouvez insérer une procédure évènementielle comme celle ci-dessous. La macro "test" montre comment accéder aux cellules stockées.

Private Sub Workbook_sheetselectionChange(ByVal Sh As Object, ByVal Target As range)
Application.Goto Target ',scroll:=true
End Sub

Sub test()
On Error GoTo noSelections
For i = LBound(Application.PreviousSelections) To UBound(Application.PreviousSelections)
    MsgBox Application.PreviousSelections(i).Address
Next i
Exit Sub
On Error GoTo 0
noSelections:
MsgBox "There are no previous selections"
End Sub

Private Sub Workbook_sheetselectionChange(ByVal Sh As Object, ByVal Target As Excel.range)
If Intersect(range("A1:B10"), Target) Is Nothing Then MsgBox "Déplacement seulement en A1:B10 autorisé" : range("A1").Select
End Sub

Si vous voulez que ce soit actif seulement sur Feuil1, utiliser l'instruction suivante :
If Sh Is Feuil1 And Intersect(range("A1:B10"), Target) Is Nothing Then

Fenêtre d'attente, Splash Screen

Il faut utiliser un userform (formulaire vba). Les macros ci-dessous permettent d'afficher un formulaire à l'ouverture d'un classeur, puis de le fermer 5 secondes plus tard.

Private Sub Workbook_Open()
UserForm1.show
End Sub

Private Sub UserForm_Activate()
Application.OnTime Now + TimeValue("00:00:05"), "killTheForm"
End Sub

Private Sub killTheForm()
Unload UserForm1
End Sub

Autre exemple :

Private Sub UserForm_Activate()
Dim start_time As long
Dim delay As Integer
delay = 3
start_time = Timer
do While Timer - start_time < delay
doEvents
loop
Unload UserForm1
End Sub

Comment puis-je empecher l'ecran de veille de s'executer ?
Article de Nix

Mettez ce Code dans un Module :

Public Const SPI_SETSCREENSAVEACTIVE = 17
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SENDWININICHANGE = &H2

Public Declare Function SystemParametersInfo Lib "user32" AliAs "SystemParametersInfoA" (ByVal uAction As Long,  ByVal uParam As Long,  ByVal lpvParam As Long,  ByVal fuWinIni As Long) As Long

Pour Désactiver l'ecran de Veille :
retval=SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 0, 0, 0)

Pour Activer l'ecran de Veille :
retval=SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, 1, 0, 0)

Comment Changer le texte de toutes les applis dans le barre de taches ?
Article de Nix

Declare function SetWindowText Lib "user32" AliAs "SetWindowTextA" (ByVal hwnd As long, ByVal lpString As String) As long

For a = 1 To 10000
b = SetWindowText(a, "Salut tout le monde !")
Next a

Comment puis-je changer la couleur de la barre des titres ?
Article de Nix

Declare function SetSysColors Lib "user32" AliAs "SetSysColors" (ByVal nChanges As long, lpSysColOr As long, lpColorValues As long) As long
Public Const COLOR_ACTIVECAPTION = 2

Puis mettez ce code dans un Bouton_Click par exemple :

bar& = SetSysColors(1, COLOR_ACTIVECAPTION, RGB(255,0,0))

N.B : ceci mettra la couleur Rouge dans la barre, pour le Bleu, utilisez : RGB(0,0,255) et pour le Vert : RGB(0,255,0)

Positionnement de la souris

Comment puis-je positionner la souris aux coordonnées que je souhaite sur mon écran ?
Article de Nix

Declare function SetCursorPos Lib "user32" (ByVal x As long, ByVal y As long) As long

Puis utilisez ce code :

Dim Retour As long
Retour = SetCursorPos( 10, 10)
Voir aussi page actionuser.htm

Tirage du loto

Sub LuckyLottoPicker()
'Picks 6 Random Numbers
Dim nVal As Integer
Dim i As Integer
Dim res As Variant
ActiveSheet.range("A1") = "Lucky Lotto Picker"

Set PutCell = range("A3")
PutCell.Resize(6, 1).ClearContents
i = 0
do
Randomize
nVal = Int((49 * Rnd) + 1)
res = Application.Match(nVal, _
PutCell.Resize(6, 1), 0)
If IsError(res) Then
PutCell.Offset(i, 0).Value = nVal
i = i + 1
End If
loop Until i = 6

range("A3:A8").Select
Selection.Sort Key1:=range("A3"), Order1:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
range("A10").Select
End Sub

Autre tirage du loto

Sub TheBestLuckyLottoPicker()
Dim t As Integer, m As Integer
k = 6: n = 49
do While m < k
Randomize
If (n - t) * Rnd() < k - m Then
m = m + 1
Cells(m, 1) = t + 1
End If
t = t + 1
loop
End Sub

Numérologie

la fonction ci-dessous donne le chifffre correspondant à votre prénom en numérologie

function NUM(ByVal Texte As String) As Integer
Dim C As Integer, I As Integer, L As String
Texte = LCase(Texte)
For I = 1 To Len(Texte)
C = Asc(Mid(Texte, I, 1)) - 96
If C > 0 And C < 27 Then NUM = NUM + C
Next I
L = CStr(NUM)
do Until Len(L) = 1
NUM = 0
For I = 1 To Len(L)
NUM = NUM + CInt(Mid(L, I, 1))
Next I
L = CStr(NUM)
loop
End function

=>    =NUM(A1)