Addin Applikationsweit nutzen!

Der Code eines Addin soll Applikationsweit zur Verfügung stehen also auch noch, wenn "Datei - Neu..." ausgeführt wird. Hier mal an einem Beispiel in dem abhängig vom Zoom und der Bildschirmauflösung bei erreichen einer bestimmten Zelle diese automatisch nach oben gescrollt wird. Mit den Funktionstasten F5 / F6 kann die Funktion ein- bzw. ausgeschaltet werden. Ist jetzt exemplarisch nur für Auflösung "1280 x 1024" und "1024 x 768". Weitere Auflösungen, Zoom bzw. andere Einschränkungen können natürlich nach belieben angepasst werden. :-)

Klassenmodul, Scrollen mit Zoom und Auflösung... [ZIP, 90 KB]

Code gehört in "DieseArbeitsmappe"

Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F5}", "Application_Ereignis.An"
Application.OnKey "{F6}", "Application_Ereignis.Aus"
Call An
End Sub
Private Sub Workbook_Deactivate()
Application.OnKey "{F5}"
Application.OnKey "{F6}"
Call Aus
End Sub

Code gehört in ein allgemeines Modul mit Namen "Application_Ereignis"

Option Explicit
Option Private Module
Private Declare Function GetDeviceCaps Lib "GDI32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
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 Sub ShowWindow Lib "User32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long)
Const HORZRES = 8
Const VERTRES = 10
Dim AppObject As New clsDatei
Function GetScreenRes()
Dim lRval As Long
Dim lDC As Long
Dim lHSize As Long
Dim lVSize As Long
lDC = GetDC(0&)
lHSize = GetDeviceCaps(lDC, HORZRES)
lVSize = GetDeviceCaps(lDC, VERTRES)
lRval = ReleaseDC(0, lDC)
GetScreenRes = lHSize & "x" & lVSize
End Function
Public Sub An()
Set AppObject.AppLiCa = Application
End Sub
Public Sub Aus()
Set AppObject.AppLiCa = Nothing
End Sub

Code gehört in ein Klassenmodul mit Namen "clsDatei"

Option Explicit
Public WithEvents AppLiCa As Application
Private Sub AppLiCa_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
Select Case GetScreenRes
Case "1280x1024"
Select Case ActiveWindow.Zoom
Case 200
If Target.Row Mod 18 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 100
If Target.Row Mod 38 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 70
If Target.Row Mod 55 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 50
If Target.Row Mod 77 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
End Select
Case "1024x768"
Select Case ActiveWindow.Zoom
Case 200
If Target.Row Mod 16 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 100
If Target.Row Mod 33 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 75
If Target.Row Mod 43 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
Case 50
If Target.Row Mod 63 = 0 Then
Application.Goto _
Reference:=Range(Target.Address), _
Scroll:=True
End If
End Select
End Select
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...