das geht z. B. so.
' **********************************************************************
' Modul: Tabelle1 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rc As RECT
If Target.Address = "$F$5" Then
rc = GetRangeRect(Target.Offset(1, 0))
With UserForm1
.StartUpPosition = 0
.Move rc.Left / fX, (rc.Top + 4) / fY
If Not .Visible Then .Show 0
End With
End If
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
'© by http://www.dailydoseofexcel.com/archives/2007/08/30/positioning-a-userform-over-a-cell/
Option Explicit
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Type POINTAPI
x As Long
y As Long
End Type
#If Win64 Then
'GDI32
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
'USER32
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe 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 PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As _
Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextW" (ByVal hWnd As Long, _
ByVal lpString As Long, ByVal cch As Long) As Long
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef _
lpdwProcessId As Long) As Long
'KERNEL32
Private Declare PtrSafe Function GetCurrentProcessId Lib "kernel32" () As Long
#Else
'GDI32
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
'USER32
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 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 Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As RECT) As _
Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextW" (ByVal hWnd As Long, _
ByVal lpString As Long, ByVal cch As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef _
lpdwProcessId As Long) As Long
'KERNEL32
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
#End If
'-------------------------------------------
'Main Functions
'-------------------------------------------
Public Function GetRangeRect(rSelection As Excel.Range) As RECT
Dim rVisible As Excel.Range
Dim wnd As Excel.Window
Dim iPane As Long
Dim rc As RECT
Dim pt As POINTAPI
On Error GoTo errH:
Set wnd = rSelection.Worksheet.Parent.Windows(1)
If PanesAreSwapped(wnd) Then Call PanesReorder(wnd)
iPane = PaneSelection(wnd, rSelection, rVisible)
If iPane = 0 Then Err.Raise vbObjectError + &H1000, "GetRangeRect", "GetRangeRect: Range not visible"
pt = PaneOrigin(wnd)
With wnd
If .FreezePanes Then
'we have to work from the middle iso the topleft of the activepane.
If .SplitColumn > 1 And (iPane = 1 Or iPane = 3) Then
pt.x = pt.x - fX * .Panes(1).VisibleRange.Width * .Zoom / 100
End If
If .SplitRow > 1 And (iPane = 1 Or (iPane = 2 And .Panes.Count > 2)) Then
pt.y = pt.y - fY * .Panes(1).VisibleRange.Height * .Zoom / 100
End If
End If
End With
rc.Left = pt.x: If rVisible.Column < rSelection.Column Then rc.Left = rc.Left + RangePixelsWidth(rVisible.Resize(, rSelection.Column - rVisible.Column))
rc.Top = pt.y: If rVisible.Row < rSelection.Row Then rc.Top = rc.Top + RangePixelsHeight(rVisible.Resize(rSelection.Row - rVisible.Row))
'this may partially extend over a split or the window edge
rc.Right = rc.Left + RangePixelsWidth(rSelection)
rc.Bottom = rc.Top + RangePixelsHeight(rSelection)
endH:
GetRangeRect = rc
errH:
End Function
Function PaneOrigin(wnd As Window) As POINTAPI
' Returns the position of the upperleft corner of the active pane
' Complexities:
' Get.Cell returns wrong headersizes if zoom is not 100. Where possible we use the move of SplitVert/SplitHorz when Displayheadings are toggled.
' Get.Cell returns wrong headerwidth if activepane has lower row magnitude than pane on other side of vertical split.
' SplitVert returns 0 if Pane1 scrollrow + visiblerange.rows.count = rows.count+1
' SplitHorz returns 0 if Pane1 scrollcol + visiblerange.cols.count = cols.count+1
' Known issues:
' With 2 pane splits small inaccuracies can occur when zoom <> 100
' but we've taken care of most exceptions. :)
Dim rc(1) As RECT
Dim fmlX As String
Dim fmlY As String
Dim dx(1) As Double
Dim dy(1) As Double
Dim dh(1) As Double
Dim dv(1) As Double
Dim bHead As Boolean 'true if DisplayHeadings is on
Dim bOutl As Boolean 'true if DisplayOutline is on
Dim bRows As Boolean 'true if pane has row headings
Dim bCols As Boolean 'true if pane has col headings
Dim bSwap As Boolean 'true if pane has row magnitude problem
Dim bDirt As Boolean 'true for temp splits
Application.ScreenUpdating = False
With wnd
If PanesAreSwapped(wnd) Then Call PanesReorder(wnd)
bHead = .DisplayHeadings
bOutl = .DisplayOutline
fmlX = "GET.CELL(42," & .ActivePane.VisibleRange.Address(1, 1, xlR1C1, 1) & ")"
fmlY = "GET.CELL(43," & .ActivePane.VisibleRange.Address(1, 1, xlR1C1, 1) & ")"
If .FreezePanes Then
'SplitH/SplitV do not move on changing DisplayHeadings.
'For 2 pane splits we have to rely on less precise zoom calculation.
.DisplayHeadings = False
.DisplayOutline = False
dx(0) = ExecuteExcel4Macro(fmlX)
dy(0) = ExecuteExcel4Macro(fmlY)
'Size of outline
.DisplayOutline = bOutl
dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
dy(1) = ExecuteExcel4Macro(fmlY) - dy(0)
.DisplayOutline = False
'Size of headers
.DisplayHeadings = bHead
dh(0) = ExecuteExcel4Macro(fmlX) - dx(0)
dv(0) = ExecuteExcel4Macro(fmlY) - dy(0)
.DisplayOutline = bOutl
'Adjust header for zoom error
If .SplitHorizontal Then dx(1) = dx(1) + dh(0) Else dx(1) = dx(1) + dh(0) * .Zoom / 100
If .SplitVertical Then dy(1) = dy(1) + dv(0) Else dy(1) = dy(1) + dv(0) * .Zoom / 100
Else
'Get the base values (excluding DisplayHeadings but including optional OutlineHeadings)
.DisplayHeadings = False
If Not .Split And bHead And .Zoom <> 100 Then
'No splits: create them
If .ScrollColumn + .VisibleRange.Columns.Count <= .ActiveSheet.Columns.Count And _
.ScrollRow + .VisibleRange.Rows.Count <= .ActiveSheet.Rows.Count Then
bDirt = True
.SplitHorizontal = .UsableWidth + 1
.SplitVertical = .UsableHeight + 1
End If
End If
dx(0) = ExecuteExcel4Macro(fmlX)
dy(0) = ExecuteExcel4Macro(fmlY)
dh(0) = .SplitHorizontal
dv(0) = .SplitVertical
If bHead Then
.DisplayHeadings = True
dh(1) = .SplitHorizontal
dv(1) = .SplitVertical
bRows = (dx(0) >= 0 And dx(0) < dh(0)) Or ((dh(0) = 0 Or dh(1) = 0) And dx(0) >= 0 And dx(0) < .Panes(1).VisibleRange.Width)
bCols = (dy(0) >= 0 And dy(0) < dv(0)) Or ((dv(0) = 0 Or dv(1) = 0) And dy(0) >= 0 And dy(0) < .Panes(1).VisibleRange.Height)
If bRows And .Split And Not .FreezePanes Then
'Swap if 'other' pane has 'wider' row headings.
bSwap = Len(Format(.ActivePane.VisibleRange.Rows(.ActivePane.VisibleRange.Rows.Count).Row, "000")) < _
Len(Format(.Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).VisibleRange.Rows(.Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).VisibleRange.Rows.Count).Row, "000"))
End If
If bRows And bSwap Then
'recompute dx(1) for the pane on the other side of the vertical split aka the horizontal bar.
.Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).Activate
dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
.Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).Activate:
.ActivePane.ScrollRow = .ActivePane.ScrollRow
ElseIf bRows Then
dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
End If
If bCols Then dy(1) = ExecuteExcel4Macro(fmlY) - dy(0)
If bRows And dh(1) > 0 And dh(1) < dh(0) Then
dx(1) = dh(0) - dh(1)
ElseIf bRows Then
'inexact when zoomed.
dx(1) = dx(1) * .Zoom / 100
End If
If bCols And dv(1) > 0 And dv(1) < dv(0) Then
dy(1) = dv(0) - dv(1)
ElseIf bCols Then
'inexact when zoomed!
dy(1) = dy(1) * .Zoom / 100
End If
If dx(1) < 0 Then dx(1) = 0
If dy(1) < 0 Then dy(1) = 0
End If
If bDirt Then .Split = False
End If
End With
Application.ScreenUpdating = True
'Rectangle coordinates
GetWindowRect xlWindowHandle(wnd), rc(0)
GetClientRect xlWindowHandle(wnd), rc(1)
PaneOrigin.x = fX * (dx(0) + dx(1)) + rc(0).Left + (rc(0).Right - rc(0).Left - rc(1).Right) \ 2
PaneOrigin.y = fY * (dy(0) + dy(1)) + rc(0).Bottom - rc(1).Bottom - (rc(0).Right - rc(0).Left - rc(1).Right) \ 2
End Function
Private Function PaneSelection(wnd As Excel.Window, ByRef rSel As Range, ByRef rVis As Range) As Long
'finds the pane where rSel is best visible
'returns: ActivePane index if selection completely visible in multiple panes.
' 0 if not visible in window
'Note:
'sets rSel to intersect of range selection and selected pane's visible range
'sets rVis to selected pane's visible range
Dim aRng(1 To 4) As Range
Dim n&, m&, mCnt&
With wnd
For n = 1 To .Panes.Count
Set aRng(n) = Intersect(rSel, .Panes(n).VisibleRange)
If Not aRng(n) Is Nothing Then
If aRng(n).Count > mCnt Then
m = n: mCnt = aRng(n).Count
ElseIf aRng(n).Count = mCnt And n = .ActivePane.Index Then
m = n
End If
End If
Next
If m Then
Set rSel = aRng(m)
Set rVis = .Panes(m).VisibleRange
PaneSelection = m
End If
End With
End Function
Function PanesAreSwapped(wnd As Excel.Window) As Boolean
'Returns true if pane2 is NorthEast in a 4pane window)
Dim aRng(1 To 4) As Excel.Range
Dim n&, dAdj#
With wnd
If .Panes.Count = 4 Then
For n = 1 To 4: Set aRng(n) = .Panes(n).VisibleRange: Next
If .FreezePanes Then
PanesAreSwapped = aRng(1).Column <> aRng(3).Column
Else
If aRng(1).Row = aRng(4).Row And aRng(1).Column = aRng(4).Column Then
If aRng(1).Height = aRng(4).Height And aRng(1).Width = aRng(4).Width Then
'totally square. we must move a split to see which is which
If .SplitHorizontal >= 50 Then dAdj = -40 Else dAdj = 40
End If
End If
If dAdj Then .SplitHorizontal = .SplitHorizontal + dAdj
PanesAreSwapped = (aRng(3).Height = aRng(1).Height And aRng(3).Width = aRng(4).Width)
If dAdj Then .SplitHorizontal = .SplitHorizontal - dAdj
End If
End If
End With
End Function
Sub PanesReorder(wnd As Excel.Window)
'Forces the panes to the default sequence
'Excel always expect the panes in NW/NE/SW/SE order.
'However when you manually drag the splitbars it is possible to create a panes
'collection where the VisibleRange of panes 2 and 3 are reversed.
Dim bFP As Boolean
Dim dSV As Double
Dim lSR(1) As Long
Dim lSC(1) As Long
Dim iPane As Long
Dim rCell As Range
Dim rSele As Range
With wnd
If .Panes.Count = 4 Then
'Store info
Set rCell = .ActiveCell
Set rSele = .RangeSelection
iPane = .ActivePane.Index
bFP = .FreezePanes
lSR(0) = .Panes(1).ScrollRow
lSR(1) = .Panes(4).ScrollRow
lSC(0) = .Panes(1).ScrollColumn
lSC(1) = .Panes(4).ScrollColumn
While .SplitVertical < 1
'avoid bug when rows are scrolled 'beyond'
.Panes(1).ScrollRow = .Panes(1).ScrollRow - 1
Wend
'Ensure Vertical is set after Horizontal
dSV = .SplitVertical
.SplitVertical = 0
.SplitVertical = dSV
'Restore info
If bFP Then .FreezePanes = True Else .Panes(iPane).Activate
rSele.Select
rCell.Activate
.Panes(1).ScrollRow = lSR(0)
.Panes(4).ScrollRow = lSR(1)
.Panes(1).ScrollColumn = lSC(0)
.Panes(4).ScrollColumn = lSC(1)
End If
End With
End Sub
'Compute width/height per cell to avoid rounding errors.
Function RangePixelsWidth(rRange As Range) As Long
Dim rCell As Range
For Each rCell In rRange.Columns
RangePixelsWidth = RangePixelsWidth + Application.WorksheetFunction.Round(fX * ActiveWindow.Zoom / 100 * rCell.Width, 0)
Next
End Function
Function RangePixelsHeight(rRange As Range) As Long
Dim rCell As Range
For Each rCell In rRange.Rows
RangePixelsHeight = RangePixelsHeight + Application.WorksheetFunction.Round(fY * ActiveWindow.Zoom / 100 * rCell.Height, 0)
Next
End Function
'ScreenResolution
Function fX() As Double
Static d As Double
If d = 0 Then d = ScreenDPI(0) / 72
fX = d
End Function
Function fY() As Double
Static d As Double
If d = 0 Then d = ScreenDPI(1) / 72
fY = d
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
Static lDpi(1) As Long
Static hDC As Long
If lDpi(0) = 0 Then
hDC = GetDC(0)
lDpi(0) = GetDeviceCaps(hDC, 88&) 'horz
lDpi(1) = GetDeviceCaps(hDC, 90&) 'vert
hDC = ReleaseDC(0, hDC)
End If
ScreenDPI = lDpi(Abs(bVert))
End Function
'Handles
Function xlApplicationHandle() As Long
Static h As Long
If h = 0 Then
If Val(Application.Version) >= 10 Then
h = Application.hWnd
Else
h = WindowHandle("XLMAIN", Application.Caption)
End If
End If
xlApplicationHandle = h
End Function
Function xlDesktopHandle() As Long
Static h As Long
If h = 0 Then h = FindWindowEx(xlApplicationHandle, 0&, "XLDESK", vbNullString)
xlDesktopHandle = h
End Function
Function xlWindowHandle(wnd As Window) As Long
Dim h As Long
h = FindWindowEx(xlDesktopHandle, 0, "EXCEL7", wnd.Caption)
If h = 0 Then h = WindowSearch(xlDesktopHandle, "EXCEL7", wnd.Caption & "*")
xlWindowHandle = h
End Function
Private Function WindowHandle(Optional ByVal sClass As String = vbNullString, Optional ByVal sCaption As String = vbNullString) As Long
Dim hTop As Long
Dim hWnd As Long
Dim hCur As Long
Dim hPid As Long
hTop = GetDesktopWindow
hCur = GetCurrentProcessId
Do
hWnd = FindWindowEx(hTop, hWnd, sClass, sCaption)
GetWindowThreadProcessId hWnd, hPid
Loop Until hPid = hCur Or hWnd = 0
WindowHandle = hWnd
End Function
Private Function WindowSearch(ByVal hTop As Long, ByVal sClass As String, ByVal sCaptionPattern As String) As Long
Dim hWnd As Long
Dim sBuf As String
Dim lLen As Long
sBuf = String(&HFF&, 0)
Do
hWnd = FindWindowEx(hTop, hWnd, sClass, vbNullString)
lLen = GetWindowText(hWnd, StrPtr(sBuf), &HFF&)
Loop Until hWnd = 0 Or LCase$(Left$(sBuf, lLen)) Like LCase$(sCaptionPattern)
WindowSearch = hWnd
End Function