| |
こんにちは。
右端の座標を拾ってくる関数などは特に無いですね。
ht tp://www.moug.net/faq/viewtopic.php?t=60244&highlight=SendInput
上記URLのAbyssさんのコードをお借りしています。
シート右側のスクロールバーの位置を拾ってきて、そこにMouseを操作して
図形を作成。そのLeftを取得し、作成した図形を削除。
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SetCursorPos Lib "user32" ( _
ByVal x As Long, _
ByVal y As Long) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" ( _
ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
Private Declare Function GetWindowRect Lib "user32" ( _
ByVal hWnd As Long, _
lpRect As RECT) As Long
Private 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)
Private Const MOUSEEVENTF_LEFTDOWN = &H2 ' left button down
Private Const MOUSEEVENTF_LEFTUP = &H4 ' left button up
Function GetRWindowPoint(ByRef sngLeft As Single) As Boolean
Dim Rc As RECT
Dim hWnd As Long
hWnd = Application.hWnd 'hWnd = FindWindowEx(0, 0, "XLMAIN", Application.Caption)
hWnd = FindWindowEx(hWnd, 0, "XLDESK", vbNullString)
hWnd = FindWindowEx(hWnd, 0, "EXCEL7", vbNullString)
hWnd = FindWindowEx(hWnd, 0, "ScrollBar", vbNullString)
If hWnd = 0 Then Exit Function
GetWindowRect hWnd, Rc
AppActivate Application.Caption
Application.CommandBars.FindControl(ID:=1111).accDoDefaultAction
SetCursorPos Rc.Left - 1, (Rc.Top + Rc.Bottom) \ 2
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
DoEvents
If TypeName(Selection) = "Range" Then Exit Function
With Selection
sngLeft = .Left
.Delete
End With
GetRWindowPoint = True
End Function
Sub Sample001()
Dim l As Single
'ActiveSheetに図形が一つ以上あるとして。
With ActiveSheet.Shapes(1)
If GetRWindowPoint(l) Then
.Left = l - .Width
End If
End With
End Sub
|
|
ちび坊主
- 12/1/25(水) 11:22 -
