حرك الماوس فوق الخلية و غير لونها ثم بين صورة أحد أعضاء المنتدى في الخلية المجاورة

[جعفر الطريبق]

السلام عليكم 

ملف للتحميل : https://app.box.com/s/v94a80af0wlm284d057fhqsjeqxdpd1y

الكود التالي يعتمد طريقة فريدة و غريبة بواسطة دالة ال HYPERLINK 

1- الكود في موديول عادي :

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long

#End If

Private ThisCell As Range
Private myShape As Shape
Private linitialColorIndex As Long
Private linitialFontColorIndex As Long

Public Sub MyMouseOverEvent_Hyplnk()
    Set ThisCell = Application.Caller
    With ThisCell
        Set ThisWorkbook.oWsh = .Worksheet
        If .Interior.ColorIndex = 6 Then .Interior.ColorIndex = linitialColorIndex
        If .Font.ColorIndex = 3 Then .Font.ColorIndex = linitialFontColorIndex
        linitialColorIndex = .Interior.ColorIndex
        linitialFontColorIndex = .Font.ColorIndex
        .Interior.ColorIndex = 6
        .Font.ColorIndex = 3
        Set myShape = .Parent.Shapes(Replace(.Name.Name, "_", ""))
        myShape.Left = .Offset(0, 2).Left + 2
        myShape.Top = .Offset(0, 2).Top + 1
        myShape.Width = .Offset(0, 2).Width - 2
        myShape.Height = .Offset(0, 2).Height - 2
        myShape.OnAction = "Dummy"
        myShape.Visible = msoTrue
        Call MouseExit
    End With
End Sub

Private Sub Dummy()
End Sub

Private Sub MouseExit()
    Dim tPt As POINTAPI
    Do
        GetCursorPos tPt
        If TypeName(ActiveWindow.RangeFromPoint(tPt.x, tPt.y)) <> "Range" Then Exit Do
        If ThisCell.Address <> ActiveWindow.RangeFromPoint(tPt.x, tPt.y).Address Then Exit Do
        DoEvents
    Loop
    ThisCell.Interior.ColorIndex = linitialColorIndex
    ThisCell.Font.ColorIndex = linitialFontColorIndex
    Set ThisCell = Nothing
    myShape.Visible = msoFalse
End Sub

 

2- الكود في ThisWorkbook Module :

Option Explicit
Public WithEvents oWsh As Worksheet

Private Sub Workbook_Open()
    Set oWsh = Sheets(1)
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim oShp As Shape
    On Error Resume Next
    For Each oShp In oWsh.Shapes
        oShp.Visible = msoFalse
    Next
End Sub

Private Sub oWsh_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
End Sub

Private Sub oWsh_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
End Sub

 

تم تعديل نوفمبر 6, 2015 بواسطه جعفر الطريبق

[محمد حسن المحمد]

الشكر الجزيل لأستاذنا المحترم جعفر الطريبق

بصراحة باستطاعني القول فوق الوصف...أروع من الرائع

جزاكم الله خيراً..والسلام عليكم.

[Yasser Fathi Albanna]

أستاذنا القدير / جعفر الطريبق

عمل فوق الروعة هائل

جزاك الله خير وأدام عليك الصحة والعافية

الله لا يحرمنا من أعمالك

[دغيدى]

شكرا أخى الكريم .. جعفر

شكرا للعمل ...  وشكرا لوضع صورتى مع الصحبة

برجاء شرح الفكرة حتى تعم الفائدة

 

[مختار حسين محمود]

  روووووووووووووووووووعة ما يجبهاش الا جعفر  شكرا لك   أخى وأستاذى العزيز  

و هذا المرفق المنقول يستخدم  نفس التكنيك Rollover Technique

عناصر الجدول الدورى الحديث.rar

تم تعديل نوفمبر 6, 2015 بواسطه مختار حسين محمود

[عبد العزيز البسكري]

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

باسم الله ما شاء الله

أنا الآن أشاهد فيلم خيالي .. و خياله أوسع من " كوسْموسْ "

بارك الله فيك أستاذنا القدير " جعفر الطريبق " على الملف الرّائع .. وما زاد إعجابي به هو سرعة و سلاسة التّنفيذ

جزاك الله خيرًا و زادها بميزان حسناتك

فائق إحتراماتي

 

 

[ياسر خليل أبو البراء]

أخي الحبيب جعفر

في منتهى منتهى الروعة والإتقان والفن ..

في انتظار شرح طريقة عمل الملف وكيفية الاستفادة منه بشكل عملي ... لا تنسانا

[عادل حنفي]

احي الحبيب جعفر الطريبق

طبعا كود ولا احلـي وياما ستجد في الاكوادمن عجائب  تسلم اخي

تحياتي

[ابراهيم الحداد]

بارك الله فيك استاذنا الجميل والله شئ يفوق الوصف

مزيد من الرقى والتقدم

[جعفر الطريبق]

السلام عليكم و بارك الله فيكم  جميعا على الردود الطيبة

الدالة Hyperlink تتقبل ماكرو في ال (First Argument ) و نتفذها عند تحريك الماوس فوق الخلية و هو حسب علمي أمر غير مقصود و غير موثق من طرف مايكروسوفت .. الكود يستغل هذه الخاصية ..كل ما يقوم به الكود هو تغيير لون الخلية و اظهار الصور المخفية مسبقا بعد تحديد مكانها قرب الخلية

الملف يستعمل أسماء Named Ranges مطابقة لأسماء الصور لاستدعاء الصور المناسبة

استعملت ال GetCursorPos API لجعل عملية اظهار و اخفاء الصور عملية سلسة و سريعة

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

 

 

تم تعديل نوفمبر 7, 2015 بواسطه جعفر الطريبق

[الصـقر]

استاذى الفاضل / جعفر الطربيق

ما شاء الله روعه وقمة فى الابداع

بارك الله فيك وزادك من علمه وفضله

تقبل تحياتى

[ياسر خليل أبو البراء]

كلام جميل أخي الحبيب جعفر

لا زلنا ننتظر المزيد من التفاصيل حول كيفية إنشاء الملف بهذه الصورة بالتفصيل ...

لو تكرمت علينا أن تشرح خطوات العمل بدون ملف مرفق ..اشرح بالخطوات 1 - 2 - 3 - 4 وهكذا لتتضح الصورة أكثر

أين يتم تخزين الصور ..وكيف يمكن التعامل مع الصور بإظهارها كلها مرة واحدة ؟؟ ولما الكليك يمين معطل في الملف المرفق من قبلكم

لا تعطيني سمكة ولكن علمني كيف أصطاد؟

[مختار حسين محمود]

بعد اذن أستاذنا جعفر أضع تصورى للفكرة

الفكرة تعتمد على أسلوب يسمى : Rollover Technique

تعتمد طريقته على حدوث شىء ما ( ظهور صورة أو نص أو ......أو ... الخ فى خلية ) بمجرد مرور الماوس على خلية أخرى والعكس

أخى وأستاذى ياسر خليل :

الصور مخزنة فى الملف وتكون متاحة أو غير متاحة حسب مرور الماوس على الخلية

الكيلك اليمين تعطيله كعدمه  ليس له علاقه بالاكواد الأصلية

زيادة وتفصيل فى المرفق التالى           تحياتى لمن أتى لنا بالفكرة .

 

 

 

فكرة Rollover Technique.rar

[محمد حسن المحمد]

السلام عليكم أخي الكريم مختار 

جزاكم الله خيراً على هذا التوضيح لكن عندما نضع True كما قلت تظهر الصورة ويعطيني out of memory 

لقد حللت لنا سر غامض ...وفقك الله لما يحب ويرضى

    myShape.Visible = msoTrue

   

 

[مختار حسين محمود]

لا أدرى أبى محمد ما السبب عندك حاول مرة أخرى

الدخول الى محرر الاكواد  وفى كود MouseExit  تحديدا  غير السطر الاخير

[محمد حسن المحمد]

24 دقائق مضت, مختار حسين محمود said:

لا أدرى أبى محمد ما السبب عندك حاول مرة أخرى

الدخول الى محرر الاكواد  وفى كود MouseExit  تحديدا  غير السطر الاخير

السلام عليكم : ما ذكرته لك سابقاً هو السطر الأخير.

[مختار حسين محمود]

جرب الملف ده 

ظهور دائم للصورة Rollover Technique.rar

تم تعديل نوفمبر 7, 2015 بواسطه مختار حسين محمود