Merhaba arkadaşlar,
Başlangıç seviyesi için internette bulduğum Mouse kullanma kodlarını derledim. Aşağıdaki kodlar Sol üstte yer alan 50'ye 50 pikselde yer alan Computer (Veya oradaki herhangi bir şey) ikonuna çift tıklıyor. Eğer adres çubuğunda Computer yazarsa tam ekran yapıyor. 600'e 500 pikselde sağ tıklayıp ikonları en büyük yapıyor. Kodlarda Computer yerine Bilgisayarım yazarsanız da Bilgisayarımı tam ekran yapar muhtemelen. Eğer daha önce çalışan bir tane paylaşılmışsa kusura bakmayın. Bir kaç tane görmüştüm ama çalıştıramamıştım. İçine sıklıkla kullandığım başka kodları da koydum. Umarım işinize yarar.
İyi çalışmalar.
İki adet modüle aşağıdakileri yazdım.
Bir tanesine XXXXXXXXXXXXXXXXXXX:
'Access the GetCursorPos function in user32.dll
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Access the GetCursorPos function in user32.dll
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
X_Pos As Long
Y_Pos As Long
End Type
'Tam ekran yapmak için yazılan kodlar
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
' Display the cursor position coordinates
Sub Get_Cursor_Pos()
Dim Hold As POINTAPI
GetCursorPos Hold
MsgBox "X Position is : " & Hold.X_Pos & Chr(10) & "Y Position is : " & Hold.Y_Pos
End Sub
' Routine to set cursor position
Sub Set_Cursor_Pos()
SetCursorPos x, y
End Sub
Diğerine XXXXXXXXXXXXXXXXXXX:
'Declare mouse clicks
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
'Declare sleep
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Daha sonra ThisWorkbok kısmına XXXXXXXXXXXXXXXXXXX:
Sub deneme()
' Form gösterme
'UserForm1.Show
' Form kaldırma
'UserForm1.Hide
'____________________________________________________________________________________________________
' Klasör seçme
'Dim DosyaSistemi
'Dim kaynak As String
'Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
'Set Obj = CreateObject("shell.application")
'Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
'kaynak = Klasor.items.Item.Path
' Klasör içinde 11111.jpg dosyasını seçme
'Dosya = kaynak & "\11111.jpg"
'____________________________________________________________________________________________________
' Hata olduğunda devam etme
'On Error Resume Next
' Bir exe dosyasını açma
'Shell ("C:\Users\i_selcuk\Desktop\GoogleChromePortable\GoogleChromePortable.exe")
' Internet sitesi yazılabilir.
'SendKeys "https://www.google.com/maps/"
'Application.Wait Now + TimeValue("00:00:01")
'SendKeys "{ENTER}"
'____________________________________________________________________________________________________
' A1 ve C5 hüçreleri arasını seçme
'Range("A1:C5").Select
'Range(Cells(1, 1), Cells(3, 5)).Select
' 1. çalışma sayfasını seçme
'Sheets(1).Select
' 2.çalışma sayfasında A1 hücresini seçme
'Sheets(2).Cells(1, 1).Select
'____________________________________________________________________________________________________
' Ctrl + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "^a"
' Shift + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "+a"
' Alt + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "%a"
' Enter'a basma
'SendKeys "{ENTER}"
' Alt + F4 basma
'SendKeys "%{F4}"
' a harfine basma
'SendKeys "a"
' A harfine basma
'SendKeys "{CAPSLOCK}a"
' Aşağı tuşuna basma
'SendKeys "{DOWN}"
' Alt + Tab tuşuna basma
'SendKeys ("%{TAB}")
' Ctrl + Tab işlemi yapılabilir.
'ActiveWindow.ActivateNext
'____________________________________________________________________________________________________
' 10 Saniye Sonra Otomatik Msgbox kapatma
'Dim AckTime As Integer, InfoBox As Object
'Set InfoBox = CreateObject("WScript.Shell")
'AckTime = 10
'Select Case InfoBox.Popup("Click OK (this window closes automatically after 10 seconds).", _
'AckTime, "This is your Message Box", 0)
'Case 1, -1
'Exit Sub
'End Select
'____________________________________________________________________________________________________
' Double Click
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
'Sleep 100
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
' Left Click
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
' Right Click
'mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
'____________________________________________________________________________________________________
' Mouse Yerini Belirleme
'SetCursorPos x, y
'x değeri soldan sağa doğru piksel sayısı
'y değeri yukarıdan aşağıya doğru piksel sayısı
Dim Hold As POINTAPI
GetCursorPos Hold
' Mouse Yerini Gösterme
'MsgBox "X Position is : " & Hold.X_Pos & Chr(10) & "Y Position is : " & Hold.Y_Pos
' Exceli minimimze etme
Application.WindowState = xlMinimized
' 2 saniye bekletme
Application.Wait Now + TimeValue("00:00:02")
' Bu değerler sanırım sürekli Excel dosyasında kalmamasını sağlıyor. Böylelikle diğer programları tam ekran yapma vs yapılabilir. Ancak çalıştıramadım.
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
'ActiveWindow.WindowState = xlMaximized
SetCursorPos 50, 50
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
Sleep 100
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
Application.Wait Now + TimeValue("00:00:01")
' Title kısmında Computer yazan pencereyi tam ekran yapar.
Dim lhWnd As Long
Dim sTitle As String
sTitle = "Computer"
lhWnd = FindWindow(vbNullString, sTitle)
ShowWindow lhWnd, vbMaximizedFocus
SetCursorPos 600, 500
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{DOWN}"
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{RIGHT}"
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{ENTER}"
MsgBox ("All Hail Megatron !!!")
End Sub
Başlangıç seviyesi için internette bulduğum Mouse kullanma kodlarını derledim. Aşağıdaki kodlar Sol üstte yer alan 50'ye 50 pikselde yer alan Computer (Veya oradaki herhangi bir şey) ikonuna çift tıklıyor. Eğer adres çubuğunda Computer yazarsa tam ekran yapıyor. 600'e 500 pikselde sağ tıklayıp ikonları en büyük yapıyor. Kodlarda Computer yerine Bilgisayarım yazarsanız da Bilgisayarımı tam ekran yapar muhtemelen. Eğer daha önce çalışan bir tane paylaşılmışsa kusura bakmayın. Bir kaç tane görmüştüm ama çalıştıramamıştım. İçine sıklıkla kullandığım başka kodları da koydum. Umarım işinize yarar.
İyi çalışmalar.
İki adet modüle aşağıdakileri yazdım.
Bir tanesine XXXXXXXXXXXXXXXXXXX:
'Access the GetCursorPos function in user32.dll
Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
' Access the GetCursorPos function in user32.dll
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
' GetCursorPos requires a variable declared as a custom data type
' that will hold two integers, one for x value and one for y value
Type POINTAPI
X_Pos As Long
Y_Pos As Long
End Type
'Tam ekran yapmak için yazılan kodlar
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
' Display the cursor position coordinates
Sub Get_Cursor_Pos()
Dim Hold As POINTAPI
GetCursorPos Hold
MsgBox "X Position is : " & Hold.X_Pos & Chr(10) & "Y Position is : " & Hold.Y_Pos
End Sub
' Routine to set cursor position
Sub Set_Cursor_Pos()
SetCursorPos x, y
End Sub
Diğerine XXXXXXXXXXXXXXXXXXX:
'Declare mouse clicks
Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, _
ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
'Declare sleep
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Daha sonra ThisWorkbok kısmına XXXXXXXXXXXXXXXXXXX:
Sub deneme()
' Form gösterme
'UserForm1.Show
' Form kaldırma
'UserForm1.Hide
'____________________________________________________________________________________________________
' Klasör seçme
'Dim DosyaSistemi
'Dim kaynak As String
'Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
'Set Obj = CreateObject("shell.application")
'Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
'kaynak = Klasor.items.Item.Path
' Klasör içinde 11111.jpg dosyasını seçme
'Dosya = kaynak & "\11111.jpg"
'____________________________________________________________________________________________________
' Hata olduğunda devam etme
'On Error Resume Next
' Bir exe dosyasını açma
'Shell ("C:\Users\i_selcuk\Desktop\GoogleChromePortable\GoogleChromePortable.exe")
' Internet sitesi yazılabilir.
'SendKeys "https://www.google.com/maps/"
'Application.Wait Now + TimeValue("00:00:01")
'SendKeys "{ENTER}"
'____________________________________________________________________________________________________
' A1 ve C5 hüçreleri arasını seçme
'Range("A1:C5").Select
'Range(Cells(1, 1), Cells(3, 5)).Select
' 1. çalışma sayfasını seçme
'Sheets(1).Select
' 2.çalışma sayfasında A1 hücresini seçme
'Sheets(2).Cells(1, 1).Select
'____________________________________________________________________________________________________
' Ctrl + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "^a"
' Shift + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "+a"
' Alt + a harfine basma. Harfler küçük harf olarak yazılmalıdır.
'SendKeys "%a"
' Enter'a basma
'SendKeys "{ENTER}"
' Alt + F4 basma
'SendKeys "%{F4}"
' a harfine basma
'SendKeys "a"
' A harfine basma
'SendKeys "{CAPSLOCK}a"
' Aşağı tuşuna basma
'SendKeys "{DOWN}"
' Alt + Tab tuşuna basma
'SendKeys ("%{TAB}")
' Ctrl + Tab işlemi yapılabilir.
'ActiveWindow.ActivateNext
'____________________________________________________________________________________________________
' 10 Saniye Sonra Otomatik Msgbox kapatma
'Dim AckTime As Integer, InfoBox As Object
'Set InfoBox = CreateObject("WScript.Shell")
'AckTime = 10
'Select Case InfoBox.Popup("Click OK (this window closes automatically after 10 seconds).", _
'AckTime, "This is your Message Box", 0)
'Case 1, -1
'Exit Sub
'End Select
'____________________________________________________________________________________________________
' Double Click
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
'Sleep 100
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
' Left Click
'mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
' Right Click
'mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
'Sleep 50
'mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
'____________________________________________________________________________________________________
' Mouse Yerini Belirleme
'SetCursorPos x, y
'x değeri soldan sağa doğru piksel sayısı
'y değeri yukarıdan aşağıya doğru piksel sayısı
Dim Hold As POINTAPI
GetCursorPos Hold
' Mouse Yerini Gösterme
'MsgBox "X Position is : " & Hold.X_Pos & Chr(10) & "Y Position is : " & Hold.Y_Pos
' Exceli minimimze etme
Application.WindowState = xlMinimized
' 2 saniye bekletme
Application.Wait Now + TimeValue("00:00:02")
' Bu değerler sanırım sürekli Excel dosyasında kalmamasını sağlıyor. Böylelikle diğer programları tam ekran yapma vs yapılabilir. Ancak çalıştıramadım.
'Application.ScreenUpdating = True
'Application.ScreenUpdating = False
'ActiveWindow.WindowState = xlMaximized
SetCursorPos 50, 50
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
Sleep 100
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
Application.Wait Now + TimeValue("00:00:01")
' Title kısmında Computer yazan pencereyi tam ekran yapar.
Dim lhWnd As Long
Dim sTitle As String
sTitle = "Computer"
lhWnd = FindWindow(vbNullString, sTitle)
ShowWindow lhWnd, vbMaximizedFocus
SetCursorPos 600, 500
mouse_event MOUSEEVENTF_RIGHTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_RIGHTUP, 0, 0, 0, 0
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{DOWN}"
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{RIGHT}"
Application.Wait Now + TimeValue("00:00:01")
SendKeys "{ENTER}"
MsgBox ("All Hail Megatron !!!")
End Sub