자료실

부자는 돈을 써서 시간을 아끼지만 가난한 사람은 시간을 써서 돈을 아낀다

vb6.0/vba

IT HUB를 찾아주셔서 감사합니다.

vba [vba] 현재셀(ActiveCell)의 Screen X/Y 좌표 알아내기

페이지 정보

profile_image
작성자 하나를하더라도최선을
댓글 0건 조회 7,940회 작성일 20-02-11 12:54

본문


 
#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Private Type POINTAPI
    x As Long
    y As Long
End Type
 
Private Function ScreenDPI(bVert As BooleanAs Long
  'in most cases this simply returns 96
  #If VBA7 Then
  Static lDPI(1As LongPtr, lDC As LongPtr
  #Else
  Static lDPI(1As Long, lDC As Long
  #End If
  
  If lDPI(0= 0 Then
    lDC = GetDC(0)
    lDPI(0= GetDeviceCaps(lDC, 88&)    'horz
    lDPI(1= GetDeviceCaps(lDC, 90&)    'vert
    lDC = ReleaseDC(0, lDC)
  End If
  ScreenDPI = Val(lDPI(Abs(bVert)))
End Function
 
Private Function PTtoPX(Points As Single, bVert As BooleanAs Long
    PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
 
Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
    Dim wnd As Window
    Set wnd = rng.Parent.Parent.Windows(1)
    With rng
      rc.Left = PTtoPX(.Left * wnd.Zoom / 1000) _
                + wnd.PointsToScreenPixelsX(0)
      rc.Top = PTtoPX(.Top * wnd.Zoom / 1001) _
               + wnd.PointsToScreenPixelsY(0)
      rc.Right = PTtoPX(.Width * wnd.Zoom / 1000) _
                 + rc.Left
      rc.Bottom = PTtoPX(.Height * wnd.Zoom / 1001) _
                  + rc.Top
    End With
End Sub
 
Sub GetCoordinateXY()
    Dim rc As RECT
    On Error GoTo done
    Call GetRangeRect(ActiveCell, rc)
    Dim x As Long, y As Long
    x = rc.Left
    y = rc.Top
    Debug.Print x, y
done:
End Sub

댓글목록

등록된 댓글이 없습니다.