|
Hallo FireFox,
was einfach anmutet, entpuppt sich als etwas schwierige Aufgabe....
Dein Ansinnen umzusetzen erfordert daher einiges an Code. Um die Mitte des Fensters zu ermitteln gibt es keine mir bekannte Möglichkeiten.
Eine Auszählung der Positionsmitte über die sichtbaren Zellen erweist sich als nicht so einfach, weil wo verschwinden die Zellen außerhalb des Rahmens usw..
Falls nicht noch jemand eine einfachere und/oder bessere Lösung hat, kann ich Dir die u.a. Lösung anbieten, die aber möglicherweise nicht hundertprozentig zentriert, je nach dem was, ausgeblendet ist und wie gescrollt wurde.
Probiere es einfach aus und entscheide selbst, ob es Deinen Ansprüchen genügt.
Code:
01
02
03
04
05
06
07
08
09
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54 |
|
Private Declare PtrSafe Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub GrossKlein()
Dim vArr As Variant, Pty As Long, Ptx As Long
Dim R As RECT, AC As Object, yM As Long, xM As Long, yPos As Double, XPos As Double
Dim iZL As Long, iSP As Long
Const f As Single = 1.6 ' Vergößerungsfaktor
With ActiveSheet.Shapes(Application.Caller)
Set AC = ActiveWindow.ActivePane
If .AlternativeText = "" Then
.AlternativeText = .Left & ";" & .Top & ";" & .WIDTH & ";" & .HEIGHT
.ScaleWidth f, msoFalse
.ScaleHeight f, msoFalse
.ZOrder msoBringToFront
GetWindowRect Application.hwnd, R
' Mitte des Excelfenster
xM = R.Left + (R.Right - R.Left) \ 2
yM = (R.Top + (R.Bottom - R.Top) \ 2) + CommandBars("Ribbon").Controls(1).HEIGHT - 82
For iZL = 1 To 1000
If AC.PointsToScreenPixelsY(Cells(iZL, "A").Top) > yM Then Exit For
Next
For iSP = 1 To 1000
If AC.PointsToScreenPixelsX(Cells(1, iSP).Left) > xM Then Exit For
Next
With Cells(iZL - 1, iSP - 1)
yPos = .Top + ((.Offset(1, 0).Top - .Top) \ 2)
XPos = .Left + ((.Offset(0, 1).Left - .Left) \ 2)
End With
.Left = XPos - (.WIDTH \ 2)
.Top = yPos - (.HEIGHT \ 2)
Else
vArr = Split(.AlternativeText, ";")
.Left = vArr(0): .Top = vArr(1)
.WIDTH = vArr(2): .HEIGHT = vArr(3)
.AlternativeText = ""
End If
Ptx = AC.PointsToScreenPixelsX(.Left + (.WIDTH \ 2))
Pty = AC.PointsToScreenPixelsY(.Top + (.HEIGHT \ 2))
SetCursorPos Ptx, Pty
End With
End Sub
|
_________
viele Grüße
Karl-Heinz
|