VBA获取一个控件的屏幕位置

chuhaiou

下面是在网上找到的VB获取一个控件的屏幕位置，怎么用运用它呢

GetControlRECT.Bas

'//////////////////////////////////////////////////////////////////////////////////////////////////////////

'ProgrammingBy Kejisoft (Http://Hi.Baidu.com/Kejisoft)        //
'Date：2011-02-10                                                                        //
'Functions：                                                                                 //
' GetDesktopWindowRect                                                  //
'              获取一个控件在屏幕用Rect描述的位置                         //
' SetCursorToControl                                                         //
'                设置鼠标指针到一个控件                                                'IDE:Microsoft Visual Basic 6.0企业版                                           //

'//////////////////////////////////////////////////////////////////////////////////////////////////////////

Declare FunctionGetDesktopWindow Lib "user32" () As Long
Declare Function GetWindowRect Lib"user32" (ByVal Hwnd As Long, lpRect As RECT) As Long
Type RECT
    Left AsLong
    Top AsLong
    Right AsLong
    Bottom AsLong
End Type

Declare Function GetCursorPosLib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
    X As Long
    Y As Long
End Type

Declare Function SetCursorPosLib "user32" (ByVal X As Long, ByVal Y As Long) As Long

'/////////////////////////////////////////Functions////////////////////////////////////////////////////////////////

Public Function GetDesktopWindowRect(HwndAs Long, Rct As RECT, MousePos As POINTAPI) As Boolean
    Dimexecute As Integer
    execute =GetWindowRect(Hwnd, Rct)
   GetDesktopWindowRect = IIf(execute = 0, False, True)
   GetCursorPos MousePos
   
End Function

Public FunctionSetCursorToControl(ControlHwnd As Long) As Boolean
    Dim Rect2As RECT, MousePos2 As POINTAPI
    DimControlX As Long, ControlY As Long
   SetCursorToControl = GetDesktopWindowRect(ControlHwnd, Rect2, MousePos2)
    '计算控件的中心位置坐标
    ControlX= Rect2.Left + ((Rect2.Right - Rect2.Left) / 2)
    ControlY= Rect2.Top + ((Rect2.Bottom - Rect2.Top) / 2)
   
   SetCursorPos ControlX, ControlY
   

End Function

说明：本模块的函数可以获取一个控件的屏幕位置，并可以设置鼠标指针到该控件上，另外利用该函数可以实现控件的鼠标MouseOut事件，因此可以利用其制作漂亮的控件（按钮、CheckBox、Option等）。

banjinjiu

'模块代码：

1. Declare Function GetDesktopWindow Lib "user32" () As Long
   
2. Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
   
3. Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
   
4. Declare Function SetCursorPos Lib "user32" (ByVal X As Long, ByVal Y As Long) As Long
   
5. 
   
6. Type RECT
   
7. Left As Long
   
8. Top As Long
   
9. Right As Long
   
10. Bottom As Long
    
11. End Type
    
12. 
    
13. Type POINTAPI
    
14. X As Long
    
15. Y As Long
    
16. End Type
    
17. 
    
18. Public Function GetDesktopWindowRect(hwnd As Long, Rct As RECT, MousePos As POINTAPI) As Boolean
    
19. Dim execute As Integer
    
20. execute = GetWindowRect(hwnd, Rct)
    
21. GetDesktopWindowRect = IIf(execute = 0, False, True)
    
22. GetCursorPos MousePos
    
23. End Function
    
24. 
    
25. Public Function SetCursorToControl(ControlHwnd As Long) As Boolean
    
26. Dim Rect2 As RECT, MousePos2 As POINTAPI
    
27. Dim ControlX As Long, ControlY As Long
    
28. SetCursorToControl = GetDesktopWindowRect(ControlHwnd, Rect2, MousePos2)
    
29. '计算控件的中心位置坐标
    
30. ControlX = Rect2.Left + ((Rect2.Right - Rect2.Left) / 2)
    
31. ControlY = Rect2.Top + ((Rect2.Bottom - Rect2.Top) / 2)
    
32. SetCursorPos ControlX, ControlY
    
33. End Function

复制代码

'窗体代码：（两个命令按钮，其实一个也可以，在立即窗口查看）

1. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   
2. Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
   
3. Private Sub CommandButton1_Click()
   
4. Dim Rects As RECT, ExecuteValue As Boolean
   
5. Dim MousePoint As POINTAPI
   
6. hwnd& = FindWindow(vbNullString, "UserForm1")
   
7. hDC = GetDC(hwnd)
   
8. ExecuteValue = GetDesktopWindowRect(hwnd, Rects, MousePoint)
   
9. Debug.Print "ExecuteValue=" & ExecuteValue
   
10. Debug.Print "Rects.Top=" & Rects.Top
    
11. Debug.Print "Rects.Left=" & Rects.Left
    
12. Debug.Print "Rect.Bottom=" & Rects.Bottom
    
13. Debug.Print "Rect.Right=" & Rects.Right
    
14. Debug.Print "MousePoint.X= " & MousePoint.X
    
15. Debug.Print "MousePoint.Y=" & MousePoint.Y
    
16. 'MsgBox "执行结果请看立即窗口！", 48, "提示"
    
17. End Sub
    
18. Private Sub CommandButton2_Click()
    
19. hwnd& = FindWindow(vbNullString, "UserForm1")
    
20. hDC = GetDC(hwnd)
    
21. SetCursorToControl hwnd
    
22. End Sub

复制代码

chuhaiou

谢谢，太谢谢了。

banjinjiu

请教一个问题：在ppt放映模式下动态添加一个image控件，并添加图片
例1：成功(在ppt放映模式下动态添加一个image控件)

1. Private Sub CommandButton1_Click()
   
2.     fName = "C:\Users\Administrator\Desktop\2.jpg"
   
3.     Set pic = ActivePresentation.Slides(1).Shapes.AddOLEObject _
   
4.         (Left:=180, Top:=100, Width:=365, Height:=295, ClassName:="Forms.Image.1", Link:=msoTrue)
   
5. End Sub

复制代码

例2：不成功（在ppt放映模式下动态添加一个image控件，并添加图片）

1. Private Sub CommandButton1_Click()
   
2.     fName = "C:\Users\Administrator\Desktop\2.jpg"
   
3.     Set pic = ActivePresentation.Slides(1).Shapes.AddOLEObject _
   
4.         (Left:=180, Top:=100, Width:=365, Height:=295, ClassName:="Forms.Image.1", Link:=msoTrue)
   
5.     Image1.Picture = LoadPicture(fName)
   
6.     'pic.Picture = LoadPicture(fName)
   
7. End Sub

复制代码

请问：例2的程序如何修改？才能让image1控件添加图片。如果使用两个程序，我的问题能解决添加。程序就不附上了。


另：怎样用VBA实现保留原来的格式粘贴？的帖子，说清楚，并上传附件，说不定，我会做。
请用”回复“来回复我，自言自语，我看不到。

dljyh2009

看不懂，留个记号