
10-10-13, 16:27
|
 | Διαχειριστής Όνομα: Τάσος Φιλοξενιδης Έκδοση λογισμικού Office: Ms-Office 365 Γλώσσα λογισμικού Office: Ελληνική, Αγγλική, Γερμανική | | Εγγραφή: 21-10-2009
Μηνύματα: 2.011
| |
Καλησπέρα Γιώργο!
Δοκίμασε τον παρακάτω κώδικα στην κλάση "ThisWorkbook" του παραδείγματος που ανέβασες: Κώδικας: Option Explicit
Private Const SND_ASYNC = 1&
Private Declare Function PlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" ( _
ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
Private Sub PlaySoundFile(SoundPath As String)
If Dir(SoundPath, vbNormal) <> "" Then
PlaySound SoundPath, SND_ASYNC
End If
End Sub
Private Function CheckValidity(rng As Range) As Boolean
Dim ret As Double, i As Integer, EvalString As String
If WorksheetFunction.CountA(rng) = rng.Count Then
For i = 1 To rng.Count - 2
If Trim(rng(i).Value) <> vbNullString Then
EvalString = EvalString & Trim(Replace(rng(i).Value, "'", vbNullString))
Else
'PlaySoundFile "C:\Ο Φάκελος σου\Λάθος.wav
PlaySoundFile Environ("SystemRoot") & "\Media\" & "chord.wav"
MsgBox "Αφαίρεσε τα διαστήματα από το κελί " & rng(i).Address(False, False), vbInformation
Exit Function
End If
Next
ret = Evaluate(EvalString)
If rng(i + 1).Value = ret Then
'PlaySoundFile "C:\Ο Φάκελος σου\Σωστό.wav"
PlaySoundFile Environ("SystemRoot") & "\Media\" & "tada.wav"
Else
'PlaySoundFile "C:\Ο Φάκελος σου\Λάθος.wav"
PlaySoundFile Environ("SystemRoot") & "\Media\" & "chord.wav"
End If
End If
End Function
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Select Case Sh.CodeName
Case "Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5", "Sheet6"
If Target.Row < 3 Then Exit Sub
If Not Intersect(Target, Range("A:E")) Is Nothing Then
CheckValidity Range(Cells(Target.Row, Range("A:E").Column), _
Cells(Target.Row, Range("A:E").Column + _
Range("A:E").Columns.Count - 1))
ElseIf Not Intersect(Target, Range("H:L")) Is Nothing Then
CheckValidity Range(Cells(Target.Row, Range("H:L").Column), _
Cells(Target.Row, Range("H:L").Column + _
Range("H:L").Columns.Count - 1))
End If
End Select
End Sub
Καλή συνέχεια!
ΥΓ. Ελπίζω να υπάρχουν αρκετοί παππούδες σαν εσένα στην Ελλάδα μας μπας και δούμε τουλάχιστον από τις νεότερες γενεές μια άσπρη μέρα!
__________________ Ms-Office Development Team Ανάπτυξη επαγγελματικών εφαρμογών |