Excel MultiPage-posun posuvníku

[Fanatig]

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

[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 203 x

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

scroollistbox3.xlsm

(20 KiB) Staženo 98 x

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