Excel MultiPage-posun posuvníku Vyřešeno

[Fanatig]

Dobrý den ve spolek,
nevíte někdo jak nastavit posunutí pomocí kolečka myši u posuvníku MultiPage?

[Reklama]

[cmuch]

Zkus projít tady to vlákno http://social.msdn.microsoft.com/Forums ... 98ac639bea
Já to testovat nebudu

[Fanatig]

Ok děkuji:)....jen jsme se setkal se zádrhelem tam je vyžadován soubor user32.dll ,ale ten mi to nenachází to musím stáhnout nebo musím nastavit References?

[Jjg]

Stahovat asi ne, user32.dll určitě na PC máte a pokud by byl poškozen, tak by blbly Windows.

[Fanatig]

Nevíte teda proč mi to tento kod?
Je to ze stránek: http://vbaexpress.com/forum/showthread.php?t=44973
podobný kód jsem našel na stránkách od cmucha a ten taky nejde.

Kód: Vybrat vše

Option Explicit
 
 
Private Declare Function CallWindowProc _
Lib "user32.dll" _
Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal Wparam As Long, _
ByVal Lparam As Long) As Long
 
 
Private Declare Function SetWindowLong _
Lib "user32.dll" _
Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
 
 
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
 
 
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
 
 
Dim collUF As New Collection
Dim collPrevHdl As New Collection
Dim collUFHdl As New Collection
 
 
Private Function WindowProc(ByVal Lwnd As Long, _
    ByVal Lmsg As Long, _
    ByVal Wparam As Long, _
    ByVal Lparam As Long) As Long
     
     
    Dim Rotation As Long
    Dim Btn As Long
     
     
    If Lmsg = WM_MOUSEWHEEL Then
        Rotation = Wparam / 65536 ''High order word indicates direction
        Btn = Abs(Wparam) And 15 ''Low order word indicates various virtual keys held down
        MouseWheel collUF(CStr(Lwnd)), Rotation, Btn
        WindowProc = 0 ''We handled event, no need to pass on (right?)
    Else
        WindowProc = CallWindowProc(collPrevHdl(CStr(Lwnd)), _
        Lwnd, _
        Lmsg, _
        Wparam, _
        Lparam)
    End If
     
End Function
 
 
 ''Need both userform and its caption because Userform1.Caption is empty for some reason
Sub UserformHook(PassedForm As UserForm, Cap As String)
     
    Dim LocalHwnd As Long
    Dim LocalPrevWndProc As Long
    Dim ErrCounter As Integer
    Dim Counter As Integer
     
     
    LocalHwnd = FindWindow("ThunderDFrame", Cap)
    LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
     
    On Error Goto DupKey ''In case Windows assigns the same handle to a subsequent userform (altho it doesn't seem to do this)...
TryAgain:
    collUF.Add PassedForm, CStr(LocalHwnd)
    collPrevHdl.Add LocalPrevWndProc, CStr(LocalHwnd)
    collUFHdl.Add LocalHwnd
    Exit Sub
DupKey:
    If ErrCounter = 0 Then ''Avoid infinite error loop
        For Counter = 1 To collUFHdl.Count
            If collUFHdl(Counter) = LocalHwnd Then
                collUFHdl.Remove Counter
                collUF.Remove Counter
                collPrevHdl.Remove Counter
            End If
        Next
        ErrCounter = 1
        Resume TryAgain
    End If
     
End Sub
 
 
 ''Scrolls listbox 1 row or a full page if Ctrl is down
Sub MouseWheel(UF As UserForm, _
    ByVal Rotation As Long, _
    ByVal Btn As Long)
     
     
    Dim LinesToScroll As Integer
    Dim ListRows As Integer
    Dim Idx As Integer
     
     
    With UF
        If TypeName(.ActiveControl) = "ListBox" Then
            ListRows = .ActiveControl.ListCount
            If Btn = 8 Then ''Ctrl
                LinesToScroll = Int(.ActiveControl.Height / 10) ''Seems to work for font size 8
            Else
                LinesToScroll = 1
            End If
            If Rotation > 0 Then
                 'Scroll up
                Idx = .ActiveControl.TopIndex - LinesToScroll
                If Idx < 0 Then Idx = 0
                .ActiveControl.TopIndex = Idx
            Else
                 'Scroll down
                Idx = .ActiveControl.TopIndex + LinesToScroll
                If Idx > ListRows Then Idx = ListRows
                .ActiveControl.TopIndex = Idx
            End If
        End If
    End With
     
End Sub
 
Sub Test()
    UserForm1.Show
End Sub


[cmuch]

A co verze Windows a Excel, jsou 32-bitové?

// Mě na XP a Excel2007 funguje bez problémů (32bit verze)

[Jjg]

User32.dll je i součástí 64 bit systémů, dočetl jsem se, že by měl být v adresáři %windir%\SysWOW64\user32.dll (kromě WXP 64 bit). Já nemám 64 bit systém, ale můžete se podívat, zda jej na uvedené cestě máte. Rovněž jsem viděl zmínku o viru, který tuto cestu měnil.

[Fanatig]

mám Windows 7 64 bit a Office 2010 ale u toho nevím verzi na tom mi to nefunguje.Tak jsem teď zkoušel na Windows 8 a tam mi teda chybu nehlásí.Tak asi to bude nějakým tím virem...Ještě bych měl prosbičku, jelikož nevím, jak to zprovoznit, aby to normálně běželo nehodil by jste sem někdo ukázku jak vám to funguje?Zkoušel jsem to na MultiPage i na Listboxu a nic.A jelikož s makrem dělám jen chvilku, tak je to pro mě vyšší dívčí:)

[guest]

Nebudete mě mít rád, ale moje rada zní: Nechte to plavat.

S prominutím podle položené otázky na user32.dll soudím, že o API nemáte moc páru (bez urážky, ale přímo). Navíc:

Prvky na formuláří jsou pseudo ActiveX prvky (Forms 2), které se liší i od svých tehdejších sourozenců z VB6. Na plná ústa řečeno, je to odpad, vykreslovaný paskvil. Většina z nich nemá tzv. handle a 99 % z API "grafických atrakcí" na ně jednoduše nenaroubejte. I když handle mají (je to třeba skrytá vlastnost), zpravidla na nich nefunguje typická API funkce SendMessage.

API deklarace se liší pro 32/64bit Office. v 64bitových Office je navíc řada prvků na formuláři nedostupná.

Výše jsem zahlédl nějaké pokusy o hákování, subclassing. Pokud nevíte, co děláte, spadne vám Excel raz dva.

VB6 (a tedy i VBA) dost dobře ve své době neumělo rolování kolečkem myši. On byl problém i při používání kolečka v editoru VBA...

[cmuch]

Tak u mě na WinXp Ex2007 (obě 32bit) funguje bez problémů,
ale na Win7 (64bit) a Ex2010 (32bit) jde občas (tak 1 z 10 spuštění).

Jinak pro Ex 64bit jsou deklarace skoro stejné jem je tam navíc PtrSafe (Private Declare PtrSafe Function)
Kdysi jsem se o něco pokoušel aby to chodilo na všech verzích, ale vždy jsem na něčem ztroskotal.

Ale jak píše xlnc "Nechte to plavat"

[Fanatig]

Dobrá dobrá pánové nechávám plavat tu rybku jednu zákeřnou:)...když jsem tím to začal, tak jsem myslel ,že to bude nějakej jednodušší kód:) ale když je to tak tak to je přebytečný luxus:)...Ale jinak dík:) aspoň vím, že je hodně věcí co učit:)

[cmuch]

Tak přidám ještě dvě verze rolovaní v list boxu

1. Roluje hned po pomletí myši nad listboxem

scroollistbox2.xlsm

(27.2 KiB) Staženo 180 x

2. Posouvá se "mrcasením myši přes spodní či horní okraj listboxu"

scroollistbox3.xlsm

(20 KiB) Staženo 81 x

// převzato z mého odkazu výše
// pro 32bit excel