Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY As Long = 90
Private Const POINTS_PER_INCH As Long = 72
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 Declare Function GetDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hWnd As Long, ByVal hdc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32.dll" 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.dll" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Function CoordinateCell(Optional rCell As Range, Optional ScreenCoordinates As Boolean = True, Optional ByVal ResultInPixels = False) As POINTAPI
' ham tra ve toa do cua goc tren ben trai cua cell rCell trong he toa do Screen - ScreenCoordinates = TRUE
' hoac trong he toa do cua so EXCEL7 - ScreenCoordinates = FALSE
' ket qua tra ve tinh bang Pixels - ResultInPixels = TRUE hoac Points - ResultInPixels = FALSE
Dim PointsPerPixelX As Double, PointsPerPixelY As Double
Dim DC As Long, hWnd As Long, rc As RECT
Dim xStart As Long, yStart As Long, rng As Range, Arr(1 To 2)
If rCell Is Nothing Then Set rCell = ActiveSheet.Range("A1")
Set rCell = rCell(1, 1)
DC = GetDC(0)
PointsPerPixelX = POINTS_PER_INCH / GetDeviceCaps(DC, LOGPIXELSX)
PointsPerPixelY = POINTS_PER_INCH / GetDeviceCaps(DC, LOGPIXELSY)
ReleaseDC 0, DC
hWnd = FindWindow("XLMAIN", vbNullString)
hWnd = FindWindowEx(hWnd, 0, "XLDESK", vbNullString)
hWnd = FindWindowEx(hWnd, 0, "EXCEL7", vbNullString)
' toa do cua cua so EXCEL7 trong he toa do Screen
GetWindowRect hWnd, rc
' xuat phat tu trung diem canh trai cua cua so EXCEL7
xStart = rc.Left
yStart = (rc.Bottom + rc.Top) \ 2
' thuc hien vong lap cho toi khi gap cell nao do
Set rng = Application.Windows(1).RangeFromPoint(xStart, yStart)
Do While rng Is Nothing
xStart = xStart + 1
Set rng = Application.Windows(1).RangeFromPoint(xStart, yStart)
Loop
' nhay toi diem tren canh tren cua cua so EXCEL7 co cung hoanh do
yStart = rc.Top
' thuc hien vong lap cho toi khi gap cell nao do - do chinh la cell A1, va diem hien hanh la goc tren ben trai cua A1
Set rng = Application.Windows(1).RangeFromPoint(xStart, yStart)
Do While rng Is Nothing
yStart = yStart + 1
Set rng = Application.Windows(1).RangeFromPoint(xStart, yStart)
Loop
' (xStart - rc.Left) va (yStart - rc.Top) la toa do tinh bang Pixels cua goc tren ben trai cua A1
' tinh trong he toa do cua EXCEL7.
If ResultInPixels Then
If ScreenCoordinates Then
CoordinateCell.x = xStart + (rCell.Left - rng.Left) / PointsPerPixelX
CoordinateCell.y = yStart + (rCell.Top - rng.Top) / PointsPerPixelY
Else
CoordinateCell.x = (xStart - rc.Left) + (rCell.Left - rng.Left) / PointsPerPixelX
CoordinateCell.y = (yStart - rc.Top) + (rCell.Top - rng.Top) / PointsPerPixelY
End If
Else ' Points
If ScreenCoordinates Then
CoordinateCell.x = xStart * PointsPerPixelX + (rCell.Left - rng.Left)
CoordinateCell.y = yStart * PointsPerPixelY + (rCell.Top - rng.Top)
Else
CoordinateCell.x = (xStart - rc.Left) * PointsPerPixelX + (rCell.Left - rng.Left)
CoordinateCell.y = (yStart - rc.Top) * PointsPerPixelY + (rCell.Top - rng.Top)
End If
End If
End Function
