Option Explicit Private WithEvents Img As MSForms.Image Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI) Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey&) Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey&) Private Declare Function GetDC& Lib "user32" (ByVal hwnd&) Private Declare Function ReleaseDC& Lib "user32" (ByVal hwnd&, ByVal hDC&) Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&) Private Type POINTAPI X As Long Y As Long End Type Private ws As Worksheet Dim CurPos As POINTAPI Dim objTooTtip As OLEObject Private Sub Class_Initialize() Set ws = ActiveSheet End Sub Public Property Set myImg(obj As OLEObject) Set Img = obj.Object Set objTooTtip = ws.OLEObjects(Img.Name & "Tooltip") End Property Private Sub img_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _ ByVal X As Single, ByVal Y As Single) Dim b As Boolean, b2 As Boolean, hDC& With Application .Cursor = xlNorthwestArrow .CommandBars("Activex Control").Enabled = False .CommandBars("OLE Object").Enabled = False objTooTtip.BringToFront moveToolTip objTooTtip.Visible = True Do moveToolTip If GetAsyncKeyState(1) And &H8000 Then: b = True: Exit Do: Else b2 = False With ActiveWindow If TypeName(.RangeFromPoint(CurPos.X, CurPos.Y)) = "OLEObject" Then If .RangeFromPoint(CurPos.X, CurPos.Y).Name = Img.Name Then b2 = True End If End With DoEvents Loop While b2 objTooTtip.Visible = False objTooTtip.Top = Img.Top: objTooTtip.Left = Img.Left .Cursor = xlDefault .CommandBars("Activex Control").Enabled = True .CommandBars("OLE Object").Enabled = True If b Then .ScreenUpdating = False .EnableEvents = False ws.Next.Activate ws.Activate .ScreenUpdating = True .EnableEvents = True Call Test End If End With End Sub Private Sub moveToolTip() Dim hDC& GetCursorPos CurPos hDC = GetDC(0) With ActiveWindow objTooTtip.Left = (CurPos.X - .PointsToScreenPixelsX(0)) * 72 / GetDeviceCaps(hDC, 88&) * 100 / .Zoom + 10 objTooTtip.Top = (CurPos.Y - .PointsToScreenPixelsY(0)) * 72 / GetDeviceCaps(hDC, 90&) * 100 / .Zoom + 10 End With ReleaseDC 0, hDC End Sub
[/vba]
Upd. Поменял в коде две строки местами
У мну еще 1 вариант нарисовался
[vba]
Код
Option Explicit Private WithEvents Img As MSForms.Image Private Declare Function GetCursorPos& Lib "user32" (lpPoint As POINTAPI) Private Declare Function GetAsyncKeyState% Lib "user32" (ByVal vKey&) Private Declare Function GetKeyState% Lib "user32" (ByVal nVirtKey&) Private Declare Function GetDC& Lib "user32" (ByVal hwnd&) Private Declare Function ReleaseDC& Lib "user32" (ByVal hwnd&, ByVal hDC&) Private Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&) Private Type POINTAPI X As Long Y As Long End Type Private ws As Worksheet Dim CurPos As POINTAPI Dim objTooTtip As OLEObject Private Sub Class_Initialize() Set ws = ActiveSheet End Sub Public Property Set myImg(obj As OLEObject) Set Img = obj.Object Set objTooTtip = ws.OLEObjects(Img.Name & "Tooltip") End Property Private Sub img_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _ ByVal X As Single, ByVal Y As Single) Dim b As Boolean, b2 As Boolean, hDC& With Application .Cursor = xlNorthwestArrow .CommandBars("Activex Control").Enabled = False .CommandBars("OLE Object").Enabled = False objTooTtip.BringToFront moveToolTip objTooTtip.Visible = True Do moveToolTip If GetAsyncKeyState(1) And &H8000 Then: b = True: Exit Do: Else b2 = False With ActiveWindow If TypeName(.RangeFromPoint(CurPos.X, CurPos.Y)) = "OLEObject" Then If .RangeFromPoint(CurPos.X, CurPos.Y).Name = Img.Name Then b2 = True End If End With DoEvents Loop While b2 objTooTtip.Visible = False objTooTtip.Top = Img.Top: objTooTtip.Left = Img.Left .Cursor = xlDefault .CommandBars("Activex Control").Enabled = True .CommandBars("OLE Object").Enabled = True If b Then .ScreenUpdating = False .EnableEvents = False ws.Next.Activate ws.Activate .ScreenUpdating = True .EnableEvents = True Call Test End If End With End Sub Private Sub moveToolTip() Dim hDC& GetCursorPos CurPos hDC = GetDC(0) With ActiveWindow objTooTtip.Left = (CurPos.X - .PointsToScreenPixelsX(0)) * 72 / GetDeviceCaps(hDC, 88&) * 100 / .Zoom + 10 objTooTtip.Top = (CurPos.Y - .PointsToScreenPixelsY(0)) * 72 / GetDeviceCaps(hDC, 90&) * 100 / .Zoom + 10 End With ReleaseDC 0, hDC End Sub
Option Explicit Global ImgCollection As Collection Dim varImageHandler As ImageHandler Sub Test() MsgBox "ЫЫЫЫЫЫЫЫ" End Sub Sub CreateImages() Dim sh As Shape, oleobj As OLEObject, n& For Each oleobj In ActiveSheet.OLEObjects If oleobj.OLEType = xlOLEControl Then If TypeOf oleobj.Object Is MSForms.Image Then n = n + 1 End If Next Application.ScreenUpdating = False For Each sh In ActiveSheet.Shapes If sh.Type = msoPicture Then n = n + 1 With ActiveSheet.OLEObjects.Add("Forms.Image.1", , 0, 0, , , , sh.Left, sh.Top, sh.Width + 2, sh.Height + 2) .Object.PictureSizeMode = 3: sh.CopyPicture , xlBitmap Set .Object.Picture = PastePicture(xlBitmap) .Object.BorderStyle = 0: .Name = "Img" & n End With With ActiveSheet.OLEObjects.Add("Forms.Label.1", , 0, 0, , , , sh.Left, sh.Top, 90, 30) .Object.BackColor = -2147483624: .Object.ForeColor = -2147483625: .Object.BorderStyle = 0: .Visible = False: .Shadow = True .Object.Caption = "Инструкция": .Name = "Img" & n & "Tooltip" End With sh.Delete End If Next Application.ScreenUpdating = True Application.OnTime Now + TimeSerial(0, 0, 1), "InitImages" End Sub Sub InitImages() Dim oleobj As OLEObject Set ImgCollection = New Collection For Each oleobj In ActiveSheet.OLEObjects If oleobj.OLEType = xlOLEControl Then If TypeOf oleobj.Object Is MSForms.Image Then Set varImageHandler = New ImageHandler Set varImageHandler.myImg = oleobj ImgCollection.Add varImageHandler, oleobj.Name End If End If Next Beep End Sub
[/vba]
модуль modPastePicture взял тут (PastePicture.zip) текст подсказок можно изменить через режим конструктора, после изменения нужно нажать кнопку (или запустить макрос CreateImages, или InitImages) после добавления картинок нужно нажать кнопку или запустить макрос CreateImages [p.s.]чето я разошелся :D[/p.s.]
Upd. Заменил файл
[vba]
Код
Option Explicit Global ImgCollection As Collection Dim varImageHandler As ImageHandler Sub Test() MsgBox "ЫЫЫЫЫЫЫЫ" End Sub Sub CreateImages() Dim sh As Shape, oleobj As OLEObject, n& For Each oleobj In ActiveSheet.OLEObjects If oleobj.OLEType = xlOLEControl Then If TypeOf oleobj.Object Is MSForms.Image Then n = n + 1 End If Next Application.ScreenUpdating = False For Each sh In ActiveSheet.Shapes If sh.Type = msoPicture Then n = n + 1 With ActiveSheet.OLEObjects.Add("Forms.Image.1", , 0, 0, , , , sh.Left, sh.Top, sh.Width + 2, sh.Height + 2) .Object.PictureSizeMode = 3: sh.CopyPicture , xlBitmap Set .Object.Picture = PastePicture(xlBitmap) .Object.BorderStyle = 0: .Name = "Img" & n End With With ActiveSheet.OLEObjects.Add("Forms.Label.1", , 0, 0, , , , sh.Left, sh.Top, 90, 30) .Object.BackColor = -2147483624: .Object.ForeColor = -2147483625: .Object.BorderStyle = 0: .Visible = False: .Shadow = True .Object.Caption = "Инструкция": .Name = "Img" & n & "Tooltip" End With sh.Delete End If Next Application.ScreenUpdating = True Application.OnTime Now + TimeSerial(0, 0, 1), "InitImages" End Sub Sub InitImages() Dim oleobj As OLEObject Set ImgCollection = New Collection For Each oleobj In ActiveSheet.OLEObjects If oleobj.OLEType = xlOLEControl Then If TypeOf oleobj.Object Is MSForms.Image Then Set varImageHandler = New ImageHandler Set varImageHandler.myImg = oleobj ImgCollection.Add varImageHandler, oleobj.Name End If End If Next Beep End Sub
[/vba]
модуль modPastePicture взял тут (PastePicture.zip) текст подсказок можно изменить через режим конструктора, после изменения нужно нажать кнопку (или запустить макрос CreateImages, или InitImages) после добавления картинок нужно нажать кнопку или запустить макрос CreateImages [p.s.]чето я разошелся :D[/p.s.]