كود لاظهار صوت عند تغير الخلية بقيمة معينة

[lord]

الاخوة الافاضل

السلام عليكم ورحمة الله وبركاتة

هل يوجد كود

اولا:

لاظهار صوت معين عند تغير قيمة الخلية

مثلا :عندى الخلية x اذا تم تعديلها الى ( ممتاز ) يتم اظهار الصوت

ثانيا:

عندما تتغير الخلية يتم نســخ بيانات الصف الى ورقة اخرى اسمها (الممتازون ) مثلا وبها جميع بيانات الصف بناء على القيمة الوجودة بالخلية X ( ممتاز ) فقط

يوجد مثال شبيه يقوم بنقل الصف ولكن

مااريده هو نسخه فى ورقة اخرى

ارجو الرد

ولكم جزيل الشكر

[محمد حجازي]

السلام عليكم ...

جرب الدالة التالية :

Function sound(MyCells As range)
 If MyCells.Value = "ناجح" Then
   With Application.Assistant
      .Visible = True
      .On = True
      If Not Sounds Then Sounds = True
      .Animation = msoAnimationCharacterSuccessMajor
  End With
  sound = True
 Else
 sound = False
 End If
End Function

ولكن انتبه إلى أن المجال الذي يوجد بداخل الدالة لا يصلح إلا لخلية واحدة فقط

للأسف لم أجد الاداة Microsoft multimedia control 6.0 في محرر الـ VBA لذلك استعنت بمساعد الأوفيس لإظهار الصوت و القيام بحركة تدل على النجاح

Sound.zip

تم تعديل يناير 30, 2005 بواسطه محمد حجازي

[محمد حجازي]

السلام عليكم ...

الكود التالي لدالة وليس لإجراء ، لذلك قم بما يلي :

- الصق الكود في الـ Model

- اذهب لورقة العمل و اكتب الصيغة التالية :

=sound(A1)

الخلية A1 مثلاً هي الخلية التي سوف يظهر فيها التقدير (ناجح / راسب) ، وانتبه إلى أن المجال الذي يوجد بداخل الدالة هو لخلية واحدة فقط وبذلك فأنت مضطر إلى إرفاق دالة لكل خلية يجب أن تختبرها (يمكن ذلك عن طريق التعبئة).

الدالة السابقة بالإضافة للصوت و الحركة ترجع قيمة True إذا كانت الخلية المختبرة تحتوي على كلمة ناجح وترجع False في عكس ذلك ، ويمكنك إخفاء العامود الذي يحتوي على الدالة مثلاًَ في حال عدم رغبتك بظهور القيمتين True ، False

[محمد حجازي]

السلام عليكم ...

بالنسبة لكود النسخ ، تفضل :

Private Sub Worksheet_Change(ByVal Target As range)
Dim EndRow As Long
If Target.Column = 4 Then
 If Sheets(1).Cells(Target.Row, Target.Column).Value = "ناجح" Then
   Sheets(1).Rows(Target.Row).Copy
   EndRow = Sheets(2).range("A1").CurrentRegion.Rows.Count
   Sheets(2).Rows(EndRow + 1).Insert Shift:=xlDown
   Sheets(1).Select
 End If
End If
End Sub

ولكن يجب عليك الانتباه للملاحظات :

- الصق الكود في الورقة الأولى

- الكود يقوم بالنسخ من الورقة الأولى في الترتيب إلى الورقة الثانية في الترتيب ، ويمكنك تغيير المصدو و الوجهة بتغيير الترتيب بعد كلمة Sheets

- الكود لا يعمل إلا إذا قمت أنت بالتعديل ، أي أن الكود غير صالح في حالات تعديل قيمة الخلية عن طريق دالة معينة

تم تعديل يناير 23, 2005 بواسطه محمد حجازي

[lord]

السلام عليكم ورحمة الله وبركاته

شكرا للاستاذ العظيم

دلة الصوت عملت وبكفاءة وياريت تعمل على ملف wav سوف تكون رائع

وانت رائع بالفعل

بالنسبة للنسخ ارجو المحاولة لتعمل عند تغير الخلية بالمعادلة

وانا عارف بأن هذا ليس بالصعب على سيادتكم

حماك الله ورعاك

استاذ استاذ

مع رجاء شرح كود النسخ لكى اتعلم شى لاننى مبحبش انقل فقط

لك تحياتى

control200504@hotmail.com

[ابومؤنس]

السلام عليكم ورحمة الله

اخي الحبيب محمد هل يعمل الكود الخاص بالصوت علي اصدار محدد من الاوفيس ؟

لانة لم يعلم عندي , حيث ان الاوفيس الموجود عندي هو اوفيس 2000 ,

ارجو التوضيح وشكرا لك ,

بالتوفيق ,,,,

[محمد حجازي]

السلام عليكم ...

الأخ lord :

بالنسبة لتشغيل كود النسخ عندما تتغير قيمة الخلية بواسطة صيغة معينة ، لايوجد لدي فكرة محدد عن طريقة عمل ذلك حيث أن الأمر مرتبط بتحديد حدث لهذه الحالة و أنا لا أعرفه ، وفكرت في تحويل إجراء النسخ Sub لدالة Function ولكن وقفت أمام حقيقة مفادها أن الإجراء Function لا ينبغي أن يقوم بإجراء أي تغييرات على البيانات الموجودة داخل مصنف العمل.

على أية حال سأبحث عن طريقة لعمل ذلك و أخبرك عندما أجدها.

الأخ أبو مؤنس :

أنا أستخدم أوفيس 2003 و لا أعلم بالضبط فيما إذا كان هناك إمكانية في الأوفيس 2000 بالتحكم بخصائص مساعد الأوفيس من خلال الكود ، على أية حال يمكنك التحقق من ذلك بالضغط (عندما تكود داخل محرر الفيجوال) على الزر F2 ومن ثم البحث عن كلمة Assistant .

بالتوفيق

[محمد حجازي]

السلام عليكم ...

هذا شرح سريع لكود النسخ :

الكود يتفجر عند حدث تعديل الخلية ، حيث يتم إسناد الهدف الذي يمثل الخلية المعدلة في متغير اسمه Target من نوع range.

Dim EndRow As Long

في السطر السابق عرفنا متغير اسمه EndRow من نوع Long (أي عدد صحيح كبير) ، و الهدف من هذا المتغير هو تخزين عدد أسطر الجدول الموجود في الخلية الثانية.

If Target.Column = 4 Then

هنا يوجد شرط ، عندما تكود الخلية المعدلة في العامود الرابع تابع وإلا فأنهي الإجراء

If Sheets(1).Cells(Target.Row, Target.Column).Value = "ناجح" Then

هنا شرط آخر ، إذا كانت الخلية المعدلة تحتوي على كلمة ناجح فتابع و إلا فأنهي الإجراء.

Sheets(1).Rows(Target.Row).Copy

هنا نسخنا سطر الخلية المعدلة ، بإفتراض أن التعديل يجري في الورقة الأولى.

EndRow = Sheets(2).Range("A1").CurrentRegion.Rows.Count

هنا أسندنا عدد صفوف الجدول الموجود في الورقة الثانية في المتغير EndRow

Sheets(2).Rows(EndRow + 1).Insert Shift:=xlDown

هنا أدرجنا السطر المنسوخ في الورقة الثانية ، تحت الجدول القديم.

Sheets(1).Select

هنا حددنا الورقة الأولى في نهاية العمل.

لقد توخيت البساطة بشكل يخدم الشرح

أرجو أن أكون وفقت في ذلك

[lord]

ماشاء الله

لقد وفقت فعلا فى توصيل المعلومه كما اريد ويريد الاخرين

والتعديل ماشاء الله جميل

ارجو منك متابعة هذا الموضوع حتى تصل لحل للصوت wav , وباذن الله ستصل

شكرا

بالنسبة للاخ ابو مؤنس

كود الصوت يعمل فعلا ويعمل على اوفيس 2000 مع اظهار حركة مساعد الاوفيس

لكم جميعا الشكر

وسوف استكمل معكم باقى ما افعله حتى نصل سويا لعمل رائع

[lord]

االسلام عليكم ورحمه الله وبركاتة

الاستاذ محمد حجازى

استكمالا للموضوع

يمكن تعديل كود النسخ من أجل نقل جميع الصفوف التي تحقق الشرط دفعة واحدة (بعد الانتهاء من إدخال الدرجات فسوف يكون رائع

ارجو الاشارة الى السطر الذى يتغير وسوف اغيره

لاننى حاولت ان اغير السطر الخامس واعطيه مدى لنطاق ولم اوفق

وفى هذه الحالة سوف يعتمد على مابداخل الخلية ختى ولو معادلة او قيمة مكتوبة

لك تحياتى

[محمد حجازي]

السلام عليكم ...

الموضوع ليس بهذه البساطة يا أخ lord وتعديل الكود يتطلب القيام بمايلي :

- تعديل الإجراء السابق إلى روتين فرعي ووضعه في الـ Moudel.

- إضافة الحلقة التكرارية For Each من إجل اختبار كل خلية موجودة ضمن المجال الذي يحتوي على خلايا النتيجة (العامود المحدد) ونقل صفها في حال تحقق الشرط.

الكود الناتج :

Sub CopyRows()
Dim EndRow As Long
For Each ResultCell In Sheets(1).Columns(4).Cells
 If ResultCell.Value = "ناجح" Then
   Sheets(1).Rows(ResultCell.Row).Copy
   EndRow = Sheets(2).Range("A1").CurrentRegion.Rows.Count
   Sheets(2).Rows(EndRow + 1).Insert Shift:=xlDown
 End If
Next ResultCell
Sheets(1).Select
End Sub

مع ملاحظة أنك تستطيع تغيير رقم العامود الذي يحتوي على خلايا النتيجة من السطر الثاني في الكود.

تحياتي

[lord]

الف الف شكر

للاستاذ محمد حجازى (y)

كود جميل جدا بعد التعديل

سوف ينفع اعضاء كثيرون جدا

جزاك الله خيرا

وانا فى انتظار تعديل كود الصوت معلش انا تعبتك

[محمد حجازي]

السلام عليكم ...

لقد وجدت الحل عن طريق استخدام توابع الـ API.

الكود بعد التعديل:

Private Declare Function sndPlaySound Lib _
    "winmm.dll" Alias "sndPlaySoundA" _
    (ByVal lpszSoundName As String, ByVal _
    uFlags As Long) As Long
Function sound(MyCells As String)
    Dim MyPath As String
    If MyCells = "ناجح" Then
      sound = True
      MyPath = Workbooks("MyFile.xls").Path & "\SoundFile.wav"
      sndPlaySound MyPath, &H10
    Else
      sound = False
    End If
End Function

بالتوفيق

WAV.zip

[محمد حجازي]

السلام عليكم ...

كما أنه يمكنك الاستعانة بنظام القراءة التلقائية الموجود في الأوفيس :

الكود بلفظ عربي:

Function sound(MyCells As String)
   If MyCells = "ناجح" Then
     sound = True
     Application.Speech.Speak "muomtaz"
   Else
     sound = False
   End If
End Function

الكود بلفظ انكليزي:

Function sound(MyCells As String)
   If MyCells = "ناجح" Then
     sound = True
     Application.Speech.Speak "excellent"
   Else
     sound = False
   End If
End Function