VBA如何判断点击了哪个图片

aman1516

如题，详见附件：

VBA如何判断点击了哪个图片.rar (478.77 KB, 下载次数: 30)

2024-2-29 22:48 上传

点击文件名下载附件

原代码仅对提前待定情况下有效，请老师指点一下如何修改，谢谢！

kevinchengcw

见楼下帖子。。。。。。

kevinchengcw

可以用类模块解决

aman1516

kevinchengcw 发表于 2024-3-1 09:29
可以用类模块解决

非常感谢，经测试，改成提示：
    If Sel.Type = ppSelectionShapes Then MsgBox Sel.SlideRange.Name & " - " & Sel.ShapeRange.Name
在非播放状态下没问题。
但在播放状态下，却无任何反应；对图片插入任一个宏，也无反应，请问下是哪里问题呢（注：Office2007版）

aman1516

顶起一下，
实在不行本想用 Image 控件，无奈有的图形特性无法都用控件取代......
能否在 OnSlideShowPageChange 或其他方法实现呢？
播放时能判断点击不同的图片（/图形），以作出不同的处理

shenjianrong163

aman1516 发表于 2024-3-3 20:04
顶起一下，
实在不行本想用 Image 控件，无奈有的图形特性无法都用控件取代......
能否在 OnSlideShowPag ...

1. Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
   
2. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
   
3. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
   
4. Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
   
5. Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
   
6. 
   
7. Private Type POINTAPI
   
8.    x As Long
   
9.    y As Long
   
10. End Type
    
11. 
    
12. Private Type Rectangle
    
13.     topLeft As POINTAPI
    
14.     bottomRight As POINTAPI
    
15. End Type
    
16. 
    
17. Private Function TransformShape(osh As Shape) As Rectangle
    
18.     Dim zoomFactor As Double
    
19.     On Error Resume Next
    
20.     zoomFactor = ActivePresentation.slideShowWindow.View.Zoom / 100
    
21. 
    
22.     Dim hndDC&
    
23.     hndDC = GetDC(0)
    
24.     Dim deviceCapsX As Double
    
25.     deviceCapsX = GetDeviceCaps(hndDC, 88) / 72 ' pixels per pt horizontal (1 pt = 1/72')
    
26.     Dim deviceCapsY As Double
    
27.     deviceCapsY = GetDeviceCaps(hndDC, 90) / 72 ' pixels per pt vertical (1 pt = 1/72')
    
28. 
    
29.     With TransformShape
    
30.         ' calculate:
    
31.         .topLeft.x = osh.Left * deviceCapsX * zoomFactor
    
32.         .topLeft.y = osh.Top * deviceCapsY * zoomFactor
    
33.         .bottomRight.x = (osh.Left + osh.Width) * deviceCapsX * zoomFactor
    
34.         .bottomRight.y = (osh.Top + osh.Height) * deviceCapsY * zoomFactor
    
35.         ' translate:
    
36.         Dim lngStatus As Long
    
37.         lngStatus = ClientToScreen(hndDC, .topLeft)
    
38.         lngStatus = ClientToScreen(hndDC, .bottomRight)
    
39.     End With
    
40. 
    
41.     ReleaseDC 0, hndDC
    
42. End Function
    
43. 
    
44. 
    
45. Sub SlideShape_Click()
    
46.     Dim pointerPos As POINTAPI
    
47.     Dim shapeAsRect As Rectangle
    
48.     Dim sld As Slide
    
49.     Dim shp As Shape
    
50.     Dim p As Long
    
51.     Application.SlideShowWindows(1).View.Slide.Select '选中播放的幻灯片
    
52.     p = Application.ActiveWindow.View.Slide.slideIndex '获取当前幻灯片编号
    
53.     Set sld = ActivePresentation.Slides(p) '指定要操作的幻灯片页数（这里为播放状态的那张）
    
54.     For Each shp In sld.Shapes
    
55.         If shp.Type = msoPicture Then '判断形状类型是否为图片
    
56.             shapeAsRect = TransformShape(shp)
    
57.             GetCursorPos pointerPos '获取鼠标指针坐标
    
58.             If ((pointerPos.x <= shapeAsRect.topLeft.x) Or (pointerPos.x >= shapeAsRect.bottomRight.x) Or _
    
59.                 (pointerPos.y <= shapeAsRect.topLeft.y) Or (pointerPos.y >= shapeAsRect.bottomRight.y)) Then
    
60.                 ' 图片不在鼠标所点区域
    
61.             Else ' 图片在鼠标所点区域
    
62.                 MsgBox "你点击了第" & p & "页的“" & shp.Name & "”图片！"
    
63.                 Exit For
    
64.             End If
    
65.         End If
    
66.     Next
    
67. End Sub

复制代码

shenjianrong163

shenjianrong163 发表于 2024-3-5 23:54

郁闷！只有WPS才可用。修改如下：

1. Private Type POINTAPI
   
2.    x As Long
   
3.    y As Long
   
4. End Type
   
5. 
   
6. Private Type Rectangle
   
7.     topLeft As POINTAPI
   
8.     bottomRight As POINTAPI
   
9. End Type
   
10. 
    
11. #If Win64 And VBA7 Then
    
12.     Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    
13.     Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    
14.     Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    
15.     Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    
16.     Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    
17. #Else
    
18.     Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    
19.     Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    
20.     Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    
21.     Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    
22.     Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    
23. #End If
    
24. 
    
25. Private Function TransformShape(osh As Shape) As Rectangle
    
26.     Dim zoomFactor As Double
    
27.     On Error Resume Next
    
28.     zoomFactor = ActivePresentation.slideShowWindow.View.Zoom / 100
    
29. 
    
30.     Dim hndDC&
    
31.     hndDC = GetDC(0)
    
32.     Dim deviceCapsX As Double
    
33.     deviceCapsX = GetDeviceCaps(hndDC, 88) / 72 ' pixels per pt horizontal (1 pt = 1/72')
    
34.     Dim deviceCapsY As Double
    
35.     deviceCapsY = GetDeviceCaps(hndDC, 90) / 72 ' pixels per pt vertical (1 pt = 1/72')
    
36. 
    
37.     With TransformShape
    
38.         ' calculate:
    
39.         .topLeft.x = osh.Left * deviceCapsX * zoomFactor
    
40.         .topLeft.y = osh.Top * deviceCapsY * zoomFactor
    
41.         .bottomRight.x = (osh.Left + osh.Width) * deviceCapsX * zoomFactor
    
42.         .bottomRight.y = (osh.Top + osh.Height) * deviceCapsY * zoomFactor
    
43.         ' translate:
    
44.         Dim lngStatus As Long
    
45.         lngStatus = ClientToScreen(hndDC, .topLeft)
    
46.         lngStatus = ClientToScreen(hndDC, .bottomRight)
    
47.     End With
    
48. 
    
49.     ReleaseDC 0, hndDC
    
50. End Function
    
51. 
    
52. 
    
53. Sub SlideShape_Click()
    
54.     Dim pointerPos As POINTAPI
    
55.     Dim shapeAsRect As Rectangle
    
56.     Dim sld As Slide
    
57.     Dim shp As Shape
    
58.     Dim p As Long
    
59.     On Error Resume Next
    
60.     p = SlideShowWindows(1).View.Slide.slideIndex '获取当前播放的幻灯片编号
    
61.     Set sld = ActivePresentation.Slides(p) '指定要操作的幻灯片页数（这里为播放状态的那张）
    
62.     For Each shp In sld.Shapes
    
63.         'If shp.Type = msoPicture Then '判断形状类型是否为图片(WPS适用)
    
64.             shapeAsRect = TransformShape(shp)
    
65.             GetCursorPos pointerPos '获取鼠标指针坐标
    
66.             If ((pointerPos.x <= shapeAsRect.topLeft.x) Or (pointerPos.x >= shapeAsRect.bottomRight.x) Or _
    
67.                 (pointerPos.y <= shapeAsRect.topLeft.y) Or (pointerPos.y >= shapeAsRect.bottomRight.y)) Then
    
68.                 ' 图片不在鼠标所点区域
    
69.             Else ' 图片在鼠标所点区域
    
70.                 MsgBox "你点击了第" & p & "页的“" & shp.Name & "”图片！"
    
71.                 Exit For
    
72.             End If
    
73.         'End If
    
74.     Next
    
75. End Sub
    
76. 
    

复制代码

shenjianrong163

附件供参考：


VBA如何判断点击了哪个图片.rar (475.77 KB, 下载次数: 20)

2024-3-6 13:15 上传

点击文件名下载附件

perfect131

原来是这样

aman1516

shenjianrong163 发表于 2024-3-6 13:15
附件供参考：

非常感谢！
太强大了，这个用坐标识别的好处，是稍作修改还可以在播放地随意拖拽图片
好好学习！