تنسيق شرطى (وميض ، صوت للخلية)

**Eid Mostafa** · يناير 7, 2012

الأخوة / الأعزاء

هل يمكن عمل تنسيق شرطى بحيث فى حالة عدم تحقق شرط (ليكن على سبيل المثال ما إذا كانت القيمة أكبر ، أصغر من صفر)

فتومض الخلية بلون فى حالة أكبر من صفر وبلون آخر فى حالة أصغر من صفر ، أو يصدر عنها صوت ؟؟؟؟؟

أخوكم

عيد مصطفى

**عبدالله المجرب** · يناير 7, 2012

شاهد هذا الموضوع

http://www.officena.net/ib/index.php?showtopic=38622

او هذا

http://www.officena.net/ib/index.php?showtopic=9113

**Eid Mostafa** · يناير 7, 2012

الأخ العزيز / أبو عبد الله

لقد إطلعت على الروابط بردك السابق ، ولكنى لم أجد أنها تتوافق مع ما هو مطلوب

فهل بإمكانك التكرم وإفادتى ؟؟؟؟

خالص شكرى وتقديرى

أخوك

عيد مصطفى

**محمد يحياوي** · يناير 7, 2012

الاخ الكريم عيد مصطفى لاحظ المرفق و ان كان المرفق قريبا نستطيع مناقشته مع بعض

ملاحظة الخلية تومض و تصدر صوتا اذا كانت القيمة اكبر من 40

تنبيه صوتي مع وميض.rar

**عبدالله المجرب** · يناير 7, 2012

جرب المرفق

وميض4.rar

**Eid Mostafa** · يناير 7, 2012

الأخ العزيز / يحياوى

بداية أشكرك بالغ الشكر على إهتمامك بالرد

ستجد أنى قد أرفقت لك الملف الذى قمت بإرسالة إلى

وقد أضفت مثال بسيط للتوضيح

وما أقصدة من طلبى أن يتم عمل عمل تنسيق آلى وللتبسيط (سواء باللون ، أو بالوميض ، بالصوت)

للخلية التى تكون قيمتها أكبر أو أصغر من 0 (صفر) كما بالمرفق (خلية I9 & H9)

ولى طلب آخر أن يحدث ذلك آلياً ( دون زر بدء ، زر إيقاف)

أرجو ألا أكون قد أثقلت عليك.

خالص شكرى وتقديرى

أخوك

عيد مصطفى

تنبيه صوتي مع وميض.rar

**Eid Mostafa** · يناير 7, 2012

الأخ العزيز / أبو عبد الله

مرة أخرى أشكرك بالغ الشكر على إهتمامك بالرد

ولى طلب وهو هل يمكن أن يحدث ذلك آلياً ( دون زر بدء ، زر إيقاف) لأنى أريد إضافة الكود إلى ملف بة العديد من النتائج والأرقام.

وما أريدة أن تومض الخلايا التى لا تتفق مع النطاق المحدد (أكبر أو أصغر من صفر)

فهل بإمكانك التكرم وإفادتى ؟؟؟؟

خالص شكرى وتقديرى

أخوك

عيد مصطفى

**محمد يحياوي** · يناير 7, 2012

الاخ الفاضل عيد مصطفى لاحظ المرفق التالي

تنبيه صوتي مع 2وميض.rar

**الـعيدروس** · يناير 7, 2012

السلام عليكم

هذا كود للاستاذ الحبيب جعفر

وتم عمل تعديل بسيط ليتناسب مع طلبك

حط هذا الكود في حدث الصفحة


Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Target, Range("i9:h9")) Is Nothing Then

Select Case Target

	    Case Is <= 0

		 Call StartPulsating

		 Case Else

		 Call StopPulsating

End Select

End If

End Sub

وحط هذا الكود في مودويل


Option Explicit

Private Type POINTAPI

    x As Long

    y As Long

End Type

Private Type RECT

    Left As Long

    Top As Long

    Right As Long

    Bottom As Long

End Type

Private Declare Function FindWindow Lib "user32.dll" _

Alias "FindWindowA" _

(ByVal lpClassName As String, _

ByVal lpWindowName As String) As Long

Private Declare Function FindWindowEx Lib "user32.dll" _

Alias "FindWindowExA" _

(ByVal hWnd1 As Long, _

ByVal hWnd2 As Long, _

ByVal lpsz1 As String, _

ByVal lpsz2 As String) As Long

Private Declare Function GetDeviceCaps Lib "gdi32" ( _

ByVal hdc As Long, _

ByVal nIndex As Long) As Long

Private Declare Function GetDC Lib "user32" _

(ByVal hwnd As Long) As Long

Private Declare Function ReleaseDC Lib "user32" ( _

ByVal hwnd As Long, _

ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleDC Lib "gdi32" _

(ByVal hdc As Long) As Long

Private Declare Function CreateCompatibleBitmap Lib "gdi32" _

(ByVal hdc As Long, _

ByVal nWidth As Long, _

ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" _

(ByVal hdc As Long, _

ByVal hObject As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" _

(ByVal hObject As Long) As Long

Private Declare Function BitBlt Lib "gdi32" _

(ByVal hDestDC As Long, _

ByVal x As Long, _

ByVal y As Long, _

ByVal nWidth As Long, _

ByVal nHeight As Long, _

ByVal hSrcDC As Long, _

ByVal xSrc As Long, _

ByVal ySrc As Long, _

ByVal dwRop As Long) As Long

Private Declare Function StretchBlt Lib "gdi32" _

(ByVal hdc As Long, _

ByVal x As Long, _

ByVal y As Long, _

ByVal nWidth As Long, _

ByVal nHeight As Long, _

ByVal hSrcDC As Long, _

ByVal xSrc As Long, _

ByVal ySrc As Long, _

ByVal nSrcWidth As Long, _

ByVal nSrcHeight As Long, _

ByVal dwRop As Long) As Long

Private Declare Function InvalidateRect Lib "user32.dll" _

(ByVal hwnd As Long, _

ByVal lpRect As Long, _

ByVal bErase As Long) As Long

Private Declare Function RedrawWindow Lib "user32" _

(ByVal hwnd As Long, _

ByVal lprcUpdate As Long, _

ByVal hrgnUpdate As Long, _

ByVal fuRedraw As Long) As Long

Private Declare Function ScreenToClient Lib "user32" ( _

ByVal hwnd As Long, _

lpPoint As POINTAPI) As Long

Private Declare Function SetRect Lib "user32.dll" _

(ByRef lpRect As RECT, _

ByVal X1 As Long, _

ByVal Y1 As Long, _

ByVal X2 As Long, _

ByVal Y2 As Long) As Long

Private Declare Function CreateRectRgn Lib "gdi32.dll" _

(ByVal X1 As Long, _

ByVal Y1 As Long, _

ByVal X2 As Long, _

ByVal Y2 As Long) As Long

Private Declare Function PlaySoundAPI Lib "winmm.dll" _

Alias "PlaySoundA" _

(ByVal lpszName As String, _

ByVal hModule As Long, _

ByVal dwFlags As Long) As Long

Private Declare Function SetTimer Lib "user32.dll" _

(ByVal hwnd As Long, _

ByVal nIDEvent As Long, _

ByVal uElapse As Long, _

ByVal lpTimerFunc As Long) As Long

Private Declare Function KillTimer Lib "user32.dll" _

(ByVal hwnd As Long, _

ByVal nIDEvent As Long) As Long

Private Const SRCCOPY As Long = &HCC0020

Private Const LOGPIXELSX As Long = 88

Private Const LOGPIXELSY As Long = 90

Private Const RDW_INVALIDATE As Long = &H1

Private Const RDW_ALLCHILDREN As Long = &H80

Private Const SND_ASYNC As Long = &H1

Private Const SND_FILENAME As Long = &H20000

Private Const SND_LOOP As Long = &H8

Private Const CYCLE As Long = 40

Private Const POINTSPERINCH As Long = 72

Private Const SOUNDFILEPATHNAME As String = _

"C:\WINDOWS\MEDIA\chimes.WAV" 'change sound file as required.

Private tRect As RECT

Private tUpdateRect As RECT

Private lWBHwnd As Long

Private lMemoryDC As Long

Private lInterval As Long

Private oPulsatingRange As Range

Private vInitialRangeVal As Variant

Private bPlayBeep As Boolean

Sub StartPulsating()

Dim T As Range, C As Range

Set T = Sheets(1).Range("I9")

Set C = Sheets(1).Range("H9")

    If T <= 0 Then

    PulsateRange Target:=T, PlaySound:=True

    Exit Sub

    Else

    If C <= 0 Then

    PulsateRange Target:=C, PlaySound:=True

    Exit Sub

    End If

    End If

End Sub

Private Sub PulsateRange(ByVal Target As Range, Optional ByVal PlaySound As Boolean)

    Dim lXLDeskhwnd As Long

    vInitialRangeVal = Target

    lInterval = 0

    Set oPulsatingRange = Target

    lXLDeskhwnd = FindWindowEx(FindWindow("XLMAIN", Application.Caption) _

    , 0, "XLDESK", vbNullString)

    lWBHwnd = FindWindowEx _

    (lXLDeskhwnd, 0, "EXCEL7", vbNullString)

    If PlaySound Then

	    If Len(Dir(SOUNDFILEPATHNAME)) <> 0 Then

		    PlaySoundAPI SOUNDFILEPATHNAME, _

		    ByVal 0&, SND_FILENAME Or SND_ASYNC Or SND_LOOP

	    Else

		    bPlayBeep = True

	    End If

    End If

    Call TakeRangeSnapShot(ByVal oPulsatingRange)

End Sub

Sub StopPulsating()

    KillTimer lWBHwnd, 0

    InvalidateRect 0, 0, 0

    PlaySoundAPI vbNullString, 0, 0

    bPlayBeep = False

    lInterval = 0

End Sub

Private Sub TakeRangeSnapShot(ByVal Target As Range)

    Dim lDC As Long

    lInterval = 0

    lDC = GetDC(lWBHwnd)

    With GetRangeRect(ByVal Target)

	    Call GetRngBmpHandle(lDC, .Left, .Top, _

	    (.Right - .Left), (.Bottom - .Top))

	    SetRect tRect, .Left, .Top, .Right, .Bottom

    End With

    ReleaseDC 0, lDC

    SetTimer lWBHwnd, 0, 1, AddressOf TimerProc1

End Sub

Private Sub TimerProc1()

    Dim lDC As Long

    Dim lhRng As Long

    On Error Resume Next

    If Not ActiveSheet Is oPulsatingRange.Parent Then Exit Sub

    lDC = GetDC(lWBHwnd)

    If (GetRangeRect(ByVal oPulsatingRange).Right <> tRect.Right _

    Or GetRangeRect(ByVal oPulsatingRange).Top <> tRect.Top) Or _

    vInitialRangeVal <> oPulsatingRange.Value Then

	    InvalidateRect 0, 0, 0

	    tRect.Right = GetRangeRect(ByVal oPulsatingRange).Right

	    tRect.Top = GetRangeRect(ByVal oPulsatingRange).Top

	    vInitialRangeVal = oPulsatingRange.Value

	    KillTimer lWBHwnd, 0

	    SetTimer lWBHwnd, 0, 1, AddressOf TimerProc2

	    ReleaseDC 0, lDC

	    Exit Sub

    End If

    With tRect

	    If lInterval < (CYCLE / 2) Then

		    StretchBlt _

		    lDC, .Left - lInterval, .Top - lInterval, _

		    (.Right - .Left) + 2 * lInterval, _

		    (.Bottom - .Top) + 2 * lInterval, _

		    lMemoryDC, 0, 0, (.Right - .Left), _

		    (.Bottom - .Top), SRCCOPY

		    tUpdateRect.Left = .Left - lInterval

		    tUpdateRect.Top = .Top - lInterval

		    tUpdateRect.Right = tUpdateRect.Left + _

		    (.Right - .Left) + (2 * lInterval)

		    tUpdateRect.Bottom = tUpdateRect.Top + _

		    (.Bottom - .Top) + (2 * lInterval)

	    Else

		    With tUpdateRect

			    lhRng = CreateRectRgn _

			    (.Left, .Top, .Right, .Bottom)

		    End With

		    RedrawWindow lWBHwnd, 0, lhRng, _

		    RDW_INVALIDATE + RDW_ALLCHILDREN

		    DoEvents

		    With tUpdateRect

			    StretchBlt _

			    lDC, .Left + lInterval - (CYCLE / 2), _

			    .Top + lInterval - (CYCLE / 2), _

			    (.Right - .Left) - (lInterval - _

			    (CYCLE / 2)) * 2, (.Bottom - .Top) - _

			    (lInterval - (CYCLE / 2)) * 2, _

			    lMemoryDC, 0, 0, (tRect.Right - tRect.Left), _

			    (tRect.Bottom - tRect.Top), SRCCOPY

		    End With

	    End If

    End With

	    ReleaseDC 0, lDC

	    lInterval = lInterval + 1

	    If lInterval = CYCLE Then

		    If bPlayBeep Then Beep

		    lInterval = 0

	    End If

End Sub

Private Sub TimerProc2()

    KillTimer lWBHwnd, 0

    Call TakeRangeSnapShot(ByVal oPulsatingRange)

End Sub

Private Sub GetRngBmpHandle _

(lDC As Long, lRngLeft As Long, lRngTop As Long, _

lRngWidth As Long, lRngHeight As Long)

    Dim lBmp As Long

    lMemoryDC = CreateCompatibleDC(lDC)

    lBmp = CreateCompatibleBitmap(lDC, lRngWidth, lRngHeight)

    DeleteObject SelectObject(lMemoryDC, lBmp)

    BitBlt lMemoryDC, 0, 0, lRngWidth, lRngHeight, _

    lDC, lRngLeft, lRngTop, SRCCOPY

    ReleaseDC lMemoryDC, 0

End Sub

Private Function ScreenDPI(bVert As Boolean) As Long

    Static lDPI(1), lDC

    If lDPI(0) = 0 Then

	    lDC = GetDC(0)

	    lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)

	    lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)

	    lDC = ReleaseDC(0, lDC)

    End If

    ScreenDPI = lDPI(Abs(bVert))

End Function

Private Function PTtoPX(Points As Single, bVert As Boolean) As Long

    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH

End Function

Private Function GetRangeRect(ByVal rng As Range) As RECT

    Dim tPt1 As POINTAPI

    Dim tPt2 As POINTAPI

    Dim OWnd  As Window

    On Error Resume Next

    Set OWnd = rng.Parent.Parent.Windows(1)

    With rng

	    GetRangeRect.Left = _

	    PTtoPX(.Left * OWnd.Zoom / 100, 0) _

	    + OWnd.PointsToScreenPixelsX(0)

	    GetRangeRect.Top = _

	    PTtoPX(.Top * OWnd.Zoom / 100, 1) _

	    + OWnd.PointsToScreenPixelsY(0)

	    GetRangeRect.Right = _

	    PTtoPX(.Width * OWnd.Zoom / 100, 0) _

	    + GetRangeRect.Left

	    GetRangeRect.Bottom = _

	    PTtoPX(.Height * OWnd.Zoom / 100, 1) _

	    + GetRangeRect.Top

    End With

	 With GetRangeRect

		 tPt1.x = .Left

		 tPt1.y = .Top

		 tPt2.x = .Right

		 tPt2.y = .Bottom

		 ScreenToClient lWBHwnd, tPt1

		 ScreenToClient lWBHwnd, tPt2

	    .Left = tPt1.x

	    .Top = tPt1.y

	    .Right = tPt2.x

	    .Bottom = tPt2.y

    End With

End Function

تحياتي

عبد الحميد شقير · يناير 7, 2012

مشكور أخي عيد جزاك الله كل الخير

**Eid Mostafa** · يناير 7, 2012

الأخ العزيز / يحياوى

الأخ العزيز / العيدروس (أبو نصار) وليس (أبو نضال) :wink2:

وكل من ساهم فى هذة المشاركة

أشكركم بالغ الشكر على إهتمامكم بالرد وعلى ردودكم وإفاداتكم القيمة

بالفعل أخى العزيز يحياوى هذا ما كنت أريدة تماماً وأشكرك على الكود الأكثر من رائع.

و أخى العزيز / أبو نصار أشكرك على مساهمتك القيمة وسأقوم بتجربة الكود الذى يبدو من حجمة أنه كود من عمل محترف مثلك.

مرة أخرى أشكرك كل من ساهم فى هذة المشاركة.

خالص شكرى وتقديرى

أخوكم

عيد مصطفى

**محمد يحياوي** · يناير 7, 2012

الحمد لله انه تم المطلوب

الاخ الحبيب ابو نصارالكود الذي جلبته للاخ جعفر كود عجيب بصراحة تشكر على ذلك جزيل الشكر

**الـعيدروس** · يناير 7, 2012

وش رأيك نخلية ( أبو نضال) بيكون لقب حماسي :wink2:

هذا المرفق وفيه الكود

جرب اكتب قيمة صفر في احد خلايا I9 او H9

ولاحظ

GAFAR_F.rar

**abouelhassan** · يناير 7, 2012

استاذنا اابا نصار رائعة جديدة

ممكن طلب

اريد ان يتم التنفيذ على الخلية i4 فى كل اوراق العمل مما هو التغير الذى اعمله من فضلك

الله يرضى عليك

**Eid Mostafa** · يناير 7, 2012

أخى العزيز / أبو نصار

تحياتى لك ولكل المناضلين بأمتنا العربية

فعلاً وكما قلت لك بالمشاركة السابقة أنه كود من عمل محترف مثلك.

ولكن لى تعقيب بسيط علية ، وهو أنة يعمل فى حالة ما إذا كانت القيمة أقل من صفر.

فهل بإمكانك أن تجعلة يعمل وبنفس الآلية فى حالة ما إذا كانت القيمة أكبر من صفر أيضاً.

(بمعنى فى حالة ما إذا كانت القيمة صفر فلا نريد من الكود أن يومض ، أما سواء كانت القيمة أكبر أو أقل من صفر فيومض)

كما أرجو منك التكرم بتطبيق ذلك على المدى أو النطاق التالى (C114 إلى N114) وهو النطاق الذى أريد تطبيق عمل الكود علية.

أو تشرح لى أين أغير النطاق فى الكود من (I9 ، H9) إلى النطاق أعلاة.

خالص شكرى وتقديرى

أخوك

عيد مصطفى

**الـعيدروس** · يناير 7, 2012

جرب المرفق

عله يكون المطلوب

GAFAR_F_ALL.rar

**abouelhassan** · يناير 7, 2012

استاذنا

كل الشكر الكود به شئ غلط

بس

اريد الخلية i4

فى ا ى شيت من شيتات العمل اذا كانت اقل من 0

احترام وتقديرى

**الـعيدروس** · يناير 7, 2012

===============

(بمعنى فى حالة ما إذا كانت القيمة صفر فلا نريد من الكود أن يومض ، أما سواء كانت القيمة

أكبر

أو

أقل

من صفر فيومض) "إقتباس"

===============

بهذا الشرط سوف يومض بشكل مستمر ؟

اقل او اكبر من صفر

لو تحط شرط محدد افضل

اكبر من صفر واقل من 2 مثلا هكذا شرط مزبط

اخي الفاضل ابو الحسن فعلا الكود يخبط بوضعه الحالي لكل الاوراق

التعديل يحتاج روقان لي محاولة فيه ان شاء الله

تم تعديل يناير 7, 2012 بواسطه alidroos

**abouelhassan** · يناير 7, 2012

احترامى استاذنا بانتظار حضرتك

**الـعيدروس** · يناير 7, 2012

======================

هذا الكود لا لي فيه لاناقة ولا جمل :tongue2:

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

======================

**Eid Mostafa** · يناير 7, 2012

^{أخى العزيز / أبو نصار}

^{أشكرك كل الشكر على إهتمامك وسأحاول أن أجرب تعديل الكود أو أعدل الشرط من ناحية أخرى.}

^{خالص شكرى و تقديرى لك}

**الـعيدروس** · يناير 7, 2012

اخي عيد ماهو الشرط المراد بالضبط

ارجو التوضيح اكثر كيف اصغر من 0 واكبر من 0 ؟؟

**Eid Mostafa** · يناير 7, 2012

^{أخى العزيز / أبو نصار}

^{أنا لا أريد أن أطيل عليك ولكن وبإختصار أنا أريد أن أطبق هذا الشرط على أحد المعادلات بشيت للتدفق النقدى حيث أقوم بإدخال أرصدة أول المدة ثم أدخل التدفقات بأنواعها (مصادر / إستخدامات) وفى النهاية أحصل بالمعادلات على الرصيد الختامى للنقدية وذلك بإستخدام عدد من المعادلات.}

^{يلى ذلك أن أقوم بإدخال أرصدة كل بنك على حدة وفقاً للفترة المحددة دون معادلات (Data Entry) ، ثم هنالك معادلة وهى التى تقوم بطرح (مضاهاة) الرصيد الختامى للنقدية بمجموع أرصدة البنوك والتى تم إدخالها باليد.}

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

^{أرجو ألا أكون قد أطلت عليك بذلك.}

^{خالص شكرى و تقديرى لك}

^أخوك

^{عيد مصطفى}

**الـعيدروس** · يناير 7, 2012

اطلع على المرفق

ان شاء الله يكون المطلوب

GAFAAR_A1.rar

**Eid Mostafa** · يناير 7, 2012

^{أخى العزيز / أبو نصار}

^{أشكرك كل الشكر على إهتمامك وبالفعل هذا ما كنت أريدة تماماً.}

^{أكثر الله من أمثالك ، وجعلة فى ميزان حسناتك}

^{خالص شكرى و تقديرى لك}

^أخوك

^{عيد مصطفى}

تسجيل الدخول

تنسيق شرطى (وميض ، صوت للخلية)

الردود الموصى بها

Eid Mostafa

عبدالله المجرب

Eid Mostafa

محمد يحياوي

عبدالله المجرب

Eid Mostafa

Eid Mostafa

محمد يحياوي

الـعيدروس

عبد الحميد شقير

Eid Mostafa

محمد يحياوي

الـعيدروس

abouelhassan

Eid Mostafa

الـعيدروس

abouelhassan

الـعيدروس

abouelhassan

الـعيدروس

Eid Mostafa

الـعيدروس

Eid Mostafa

الـعيدروس

Eid Mostafa

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information