PDA

Vollständige Version anzeigen : Userform verschieben Problem mit Win7 x64 und Office 2007


alexpower
05.04.2012, 18:39
Hi,
unten stehender Code funktioniert problemlos mit allen Windows (XP -Win 7) und Office Versionen (2003,2007,2010),
außer bei Windows 7 und Office 2007 (alle Updates installiert) tritt folgendes Problem auf.

Die Userform wird immer exakt über der Zeile angezeigt. (so macht es der Code auf allen anderen Rechnern)

Aber in dieser Konstellation wird der rc.left Wert gar nicht verändert, wenn man Excel auf dem Bildschirm verschiebt und rc.top ist nicht die Position der aktuellen Zelle.

"OptionenAuftrag" ist die Userform die dann immer exakt über der Zeile stehen soll (Height von 27 und Width 449 sind fest),
variiert werden soll nur .Top und .Left


Komme mit dem Problem einfach nicht weiter.

Option Explicit

Public Sub AuftragsZeile()

' ALRow ist eine Zahl zw. 2 und 31 je nachdem welche Zeile benötigt wird
dim alrow as integer
alrow = 3 ' als Testwert

9 Sheets(1).Range("c" & ALRow).Select
10 rc = GetRangeRect(ActiveWindow.RangeSelection)
11 Sheets(1).Rows(ALRow).EntireRow.Select

12 OptionenAuftrag.Tag = ALRow
13 OptionenAuftrag.Left = rc.Left / fX - 20
14 OptionenAuftrag.Top = rc.Top / fY - 25 ' -25 = höhe der userform wegrechnen, damit über der ZEile
'OptionenAuftrag.Move rc.Left / fX - 20, rc.Top / fY - 25

15 OptionenAuftrag.Show

End Sub




'Positionierung der Userforms
'-------------------------------------------
'Main Functions
'-------------------------------------------
Public Function GetRangeRect(rSelection As Excel.Range) As RECT
1 Dim rVisible As Excel.Range
2 Dim wnd As Excel.Window
3 Dim iPane As Long
4 Dim rc As RECT
5 Dim pt As POINTAPI
6 On Error GoTo errH:

7 Set wnd = rSelection.Worksheet.Parent.Windows(1)
8 If PanesAreSwapped(wnd) Then Call PanesReorder(wnd)

9 iPane = PaneSelection(wnd, rSelection, rVisible)
10 If iPane = 0 Then Err.Raise vbObjectError + &H1000, "GetRangeRect", "GetRangeRect: Range not visible"

11 pt = PaneOrigin(wnd)
12 With wnd
13 If .FreezePanes Then
'we have to work from the middle iso the topleft of the activepane.
14 If .SplitColumn > 1 And (iPane = 1 Or iPane = 3) Then
15 pt.X = pt.X - fX * .Panes(1).VisibleRange.Width * .Zoom / 100
16 End If
17 If .SplitRow > 1 And (iPane = 1 Or (iPane = 2 And .Panes.Count > 2)) Then
18 pt.Y = pt.Y - fY * .Panes(1).VisibleRange.Height * .Zoom / 100
19 End If
20 End If
21 End With

22 rc.Left = pt.X: If rVisible.Column < rSelection.Column Then rc.Left = rc.Left + RangePixelsWidth(rVisible.Resize(, rSelection.Column - rVisible.Column))
23 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
24 rc.Right = rc.Left + RangePixelsWidth(rSelection)
25 rc.Bottom = rc.Top + RangePixelsHeight(rSelection)

26 endH:
27 GetRangeRect = rc
28 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. :)

1 Dim rc(1) As RECT
2 Dim fmlX As String
3 Dim fmlY As String

4 Dim dx(1) As Double
5 Dim dy(1) As Double
6 Dim dh(1) As Double
7 Dim dv(1) As Double

8 Dim bHead As Boolean 'true if DisplayHeadings is on
9 Dim bOutl As Boolean 'true if DisplayOutline is on

10 Dim bRows As Boolean 'true if pane has row headings
11 Dim bCols As Boolean 'true if pane has col headings
12 Dim bSwap As Boolean 'true if pane has row magnitude problem
13 Dim bDirt As Boolean 'true for temp splits

14 Application.ScreenUpdating = False

15 With wnd
16 If PanesAreSwapped(wnd) Then Call PanesReorder(wnd)

17 bHead = .DisplayHeadings
18 bOutl = .DisplayOutline

19 fmlX = "GET.CELL(42," & .ActivePane.VisibleRange.Address(1, 1, xlR1C1, 1) & ")"
20 fmlY = "GET.CELL(43," & .ActivePane.VisibleRange.Address(1, 1, xlR1C1, 1) & ")"

21 If .FreezePanes Then
'SplitH/SplitV do not move on changing DisplayHeadings.
'For 2 pane splits we have to rely on less precise zoom calculation.
22 .DisplayHeadings = False
23 .DisplayOutline = False
24 dx(0) = ExecuteExcel4Macro(fmlX)
25 dy(0) = ExecuteExcel4Macro(fmlY)

'Size of outline
26 .DisplayOutline = bOutl
27 dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
28 dy(1) = ExecuteExcel4Macro(fmlY) - dy(0)
29 .DisplayOutline = False

'Size of headers
30 .DisplayHeadings = bHead
31 dh(0) = ExecuteExcel4Macro(fmlX) - dx(0)
32 dv(0) = ExecuteExcel4Macro(fmlY) - dy(0)

33 .DisplayOutline = bOutl
'Adjust header for zoom error
34 If .SplitHorizontal Then dx(1) = dx(1) + dh(0) Else dx(1) = dx(1) + dh(0) * .Zoom / 100
35 If .SplitVertical Then dy(1) = dy(1) + dv(0) Else dy(1) = dy(1) + dv(0) * .Zoom / 100

36 Else

'Get the base values (excluding DisplayHeadings but including optional OutlineHeadings)
37 .DisplayHeadings = False
38 If Not .Split And bHead And .Zoom <> 100 Then
'No splits: create them
39 If .ScrollColumn + .VisibleRange.Columns.Count <= .ActiveSheet.Columns.Count And _
.ScrollRow + .VisibleRange.Rows.Count <= .ActiveSheet.Rows.Count Then
40 bDirt = True
41 .SplitHorizontal = .UsableWidth + 1
42 .SplitVertical = .UsableHeight + 1
43 End If
44 End If


45 dx(0) = ExecuteExcel4Macro(fmlX)
46 dy(0) = ExecuteExcel4Macro(fmlY)
47 dh(0) = .SplitHorizontal
48 dv(0) = .SplitVertical

49 If bHead Then
50 .DisplayHeadings = True
51 dh(1) = .SplitHorizontal
52 dv(1) = .SplitVertical

53 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)
54 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)

55 If bRows And .Split And Not .FreezePanes Then
'Swap if 'other' pane has 'wider' row headings.
56 bSwap = Len(Format(.ActivePane.VisibleRange.Rows(.ActivePane.VisibleRange.Rows.Count).Ro w, "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"))
57 End If
58 If bRows And bSwap Then
'recompute dx(1) for the pane on the other side of the vertical split aka the horizontal bar.
59 .Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).Activate
60 dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
61 .Panes(1 + ((.ActivePane.Index + .Panes.Count \ 2) - 1) Mod .Panes.Count).Activate:
62 .ActivePane.ScrollRow = .ActivePane.ScrollRow
63 ElseIf bRows Then
64 dx(1) = ExecuteExcel4Macro(fmlX) - dx(0)
65 End If
66 If bCols Then dy(1) = ExecuteExcel4Macro(fmlY) - dy(0)

67 If bRows And dh(1) > 0 And dh(1) < dh(0) Then
68 dx(1) = dh(0) - dh(1)
69 ElseIf bRows Then
'inexact when zoomed.
70 dx(1) = dx(1) * .Zoom / 100
71 End If
72 If bCols And dv(1) > 0 And dv(1) < dv(0) Then
73 dy(1) = dv(0) - dv(1)
74 ElseIf bCols Then
'inexact when zoomed!
75 dy(1) = dy(1) * .Zoom / 100
76 End If
77 If dx(1) < 0 Then dx(1) = 0
78 If dy(1) < 0 Then dy(1) = 0

79 End If

80 If bDirt Then .Split = False

81 End If
82 End With

83 Application.ScreenUpdating = True

'Rectangle coordinates
84 GetWindowRect xlWindowHandle(wnd), rc(0)
85 GetClientRect xlWindowHandle(wnd), rc(1)

86 PaneOrigin.X = fX * (dx(0) + dx(1)) + rc(0).Left + (rc(0).Right - rc(0).Left - rc(1).Right) \ 2
87 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

1 Dim aRng(1 To 4) As Range
2 Dim n&, m&, mCnt&

3 With wnd
4 For n = 1 To .Panes.Count
5 Set aRng(n) = Intersect(rSel, .Panes(n).VisibleRange)
6 If Not aRng(n) Is Nothing Then
7 If aRng(n).Count > mCnt Then
8 m = n: mCnt = aRng(n).Count
9 ElseIf aRng(n).Count = mCnt And n = .ActivePane.Index Then
10 m = n
11 End If
12 End If
13 Next
14 If m Then
15 Set rSel = aRng(m)
16 Set rVis = .Panes(m).VisibleRange
17 PaneSelection = m
18 End If
19 End With
End Function

Function PanesAreSwapped(wnd As Excel.Window) As Boolean
'Returns true if pane2 is NorthEast in a 4pane window)
1 Dim aRng(1 To 4) As Excel.Range
2 Dim n&, dAdj#

3 With wnd
4 If .Panes.Count = 4 Then
5 For n = 1 To 4: Set aRng(n) = .Panes(n).VisibleRange: Next
6 If .FreezePanes Then
7 PanesAreSwapped = aRng(1).Column <> aRng(3).Column
8 Else

9 If aRng(1).Row = aRng(4).Row And aRng(1).Column = aRng(4).Column Then
10 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
11 If .SplitHorizontal >= 50 Then dAdj = -40 Else dAdj = 40
12 End If
13 End If

14 If dAdj Then .SplitHorizontal = .SplitHorizontal + dAdj
15 PanesAreSwapped = (aRng(3).Height = aRng(1).Height And aRng(3).Width = aRng(4).Width)
16 If dAdj Then .SplitHorizontal = .SplitHorizontal - dAdj

17 End If
18 End If
19 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.

1 Dim bFP As Boolean
2 Dim dSV As Double
3 Dim lSR(1) As Long
4 Dim lSC(1) As Long
5 Dim iPane As Long
6 Dim rCell As Range
7 Dim rSele As Range

8 With wnd
9 If .Panes.Count = 4 Then
'Store info
10 Set rCell = .ActiveCell
11 Set rSele = .RangeSelection
12 iPane = .ActivePane.Index
13 bFP = .FreezePanes
14 lSR(0) = .Panes(1).ScrollRow
15 lSR(1) = .Panes(4).ScrollRow
16 lSC(0) = .Panes(1).ScrollColumn
17 lSC(1) = .Panes(4).ScrollColumn

18 While .SplitVertical < 1
'avoid bug when rows are scrolled 'beyond'
19 .Panes(1).ScrollRow = .Panes(1).ScrollRow - 1
20 Wend
'Ensure Vertical is set after Horizontal
21 dSV = .SplitVertical
22 .SplitVertical = 0
23 .SplitVertical = dSV

'Restore info
24 If bFP Then .FreezePanes = True Else .Panes(iPane).Activate
25 rSele.Select
26 rCell.Activate
27 .Panes(1).ScrollRow = lSR(0)
28 .Panes(4).ScrollRow = lSR(1)
29 .Panes(1).ScrollColumn = lSC(0)
30 .Panes(4).ScrollColumn = lSC(1)

31 End If
32 End With
End Sub

'Compute width/height per cell to avoid rounding errors.
Function RangePixelsWidth(rRange As Range) As Long
1 Dim rCell As Range
2 For Each rCell In rRange.Columns
3 RangePixelsWidth = RangePixelsWidth + Application.WorksheetFunction.Round(fX * ActiveWindow.Zoom / 100 * rCell.Width, 0)
4 Next
End Function
Function RangePixelsHeight(rRange As Range) As Long
1 Dim rCell As Range
2 For Each rCell In rRange.Rows
3 RangePixelsHeight = RangePixelsHeight + Application.WorksheetFunction.Round(fY * ActiveWindow.Zoom / 100 * rCell.Height, 0)
4 Next
End Function

'ScreenResolution
Function fX() As Double
1 Static d As Double
2 If d = 0 Then d = ScreenDPI(0) / 72
3 fX = d
End Function

Function fY() As Double
1 Static d As Double
2 If d = 0 Then d = ScreenDPI(1) / 72
3 fY = d
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
1 Static lDpi(1) As Long
2 Static hDC As Long
3 If lDpi(0) = 0 Then
4 hDC = GetDC(0)
5 lDpi(0) = GetDeviceCaps(hDC, 88&) 'horz
6 lDpi(1) = GetDeviceCaps(hDC, 90&) 'vert
7 hDC = ReleaseDC(0, hDC)
8 End If
9 ScreenDPI = lDpi(Abs(bVert))
End Function

'Handles
Function xlApplicationHandle() As Long
1 Static h As Long
2 If h = 0 Then
3 If Val(Application.Version) >= 10 Then
4 h = Application.hWnd
5 Else
6 h = WindowHandle("XLMAIN", Application.Caption)
7 End If
8 End If
9 xlApplicationHandle = h
End Function

Function xlDesktopHandle() As Long
1 Static h As Long
2 If h = 0 Then h = FindWindowEx(xlApplicationHandle, 0&, "XLDESK", vbNullString)
3 xlDesktopHandle = h
End Function

Function xlWindowHandle(wnd As Window) As Long
1 Dim h As Long
2 h = FindWindowEx(xlDesktopHandle, 0, "EXCEL7", wnd.Caption)
3 If h = 0 Then h = WindowSearch(xlDesktopHandle, "EXCEL7", wnd.Caption & "*")
4 xlWindowHandle = h
End Function

Private Function WindowHandle(Optional ByVal sClass As String = vbNullString, Optional ByVal sCaption As String = vbNullString) As Long
1 Dim hTop As Long
2 Dim hWnd As Long
3 Dim hCur As Long
4 Dim hPid As Long

5 hTop = GetDesktopWindow
6 hCur = GetCurrentProcessId
7 Do
8 hWnd = FindWindowEx(hTop, hWnd, sClass, sCaption)
9 GetWindowThreadProcessId hWnd, hPid
10 Loop Until hPid = hCur Or hWnd = 0
11 WindowHandle = hWnd
End Function

Private Function WindowSearch(ByVal hTop As Long, ByVal sClass As String, ByVal sCaptionPattern As String) As Long
1 Dim hWnd As Long
2 Dim sBuf As String
3 Dim lLen As Long
4 sBuf = String(&HFF&, 0)
5 Do
6 hWnd = FindWindowEx(hTop, hWnd, sClass, vbNullString)
7 lLen = GetWindowText(hWnd, StrPtr(sBuf), &HFF&)
8 Loop Until hWnd = 0 Or LCase$(Left$(sBuf, lLen)) Like LCase$(sCaptionPattern)
9 WindowSearch = hWnd
End Function

alexpower
05.04.2012, 20:29
Hi,

hab mal die relevanten DAten aus meinem Programm extrahiert und der Fehler ist immer noch nachvollziehbar.

Zelle A1 legt die Zeile fest, wo die Userform sein soll, klappt problemlos bis auf Win7 mit Office 2007.

mfg

Hajo_Zi
06.04.2012, 08:47
ich kann den Fehler nicht in Windows 7 Enterprice und 2007 nachvollziehen.

<img src="http://Hajo-Excel.de/images/grusz1.gif" align="middle" height="40" alt="Grußformel"><a href="http://Hajo-Excel.de/index.htm" onclick="window.open(this.href);return false"><img border="0" src="http://Hajo-Excel.de/images/logo_hajo3.gif" align="middle" height="40" alt="Homepage"></a>

alexpower
06.04.2012, 17:23
Hi,

kann keiner weiter das Phänomen nachvollziehen.

Es ist Windows 7 Ultimate x64 mit Office 2007 SP3 (32bit).

mfg

alexpower
06.04.2012, 20:01
Hi,

Er findet das Fenster (Zelle) nicht um die Position der UF zu ermitteln,
durch die Funktion "Function PaneOrigin" in den Zeilen 84 und 85 , tritt der Fehler auf.
Dadurch erkennt er das Windowhandle bei Win7 nicht.

Jetzt hab ich fast 2h im Einzelschrittmodus auf 2 Windows Systemen die Werte und Prozedurverlauf verglichen, wo es den Bug einbringt.

Muss ich mir jetzt den Abschnitt mal genauer vornehmen, hab nicht den blassen Schimmer wieso er das dort anders macht.
mfg

PS: vielleicht kann mir jemand Lösungsansätze geben

alexpower
07.04.2012, 20:37
So hab das Problem eingegrenzt und den Fehler in diesen 2 Funktionen erkannt.
Wieso er das falsch macht keine Ahnung.


Function xlDesktopHandle() As Long
1 Static h As Long
2 If h = 0 Then h = FindWindowEx(xlApplicationHandle, 0&, "XLDESK", vbNullString)
3 xlDesktopHandle = h
End Function

Function xlWindowHandle(wnd As Window) As Long
1 Dim h As Long
2 h = FindWindowEx(xlDesktopHandle, 0, "EXCEL7", wnd.Caption)
3 If h = 0 Then h = WindowSearch(xlDesktopHandle, "EXCEL7", wnd.Caption & "*")
4 xlWindowHandle = h
End Function


In der 2. Funktion wird "h" nicht ungleich 0, in allen anderen Win und Office Kombis bekommt "h" die gleiche Zahl zugewiesen.

Muss ich also einfach abfragen ob die Win7 Office 2007 Kombi drauf ist, und in der Funktion den Wert für "h" einfach manuell übernehmen aus der 1. Funktion.

mfg