Visual Basic, .NET, ASP, VBScript
 

   
   
     

Форум - Общий форум

Страница: 1 |

 

  Вопрос: блочный эдит Добавлено: 24.07.07 11:03  

Автор вопроса:  Fever
Здрасте всем, нужно доделать проект _быстро_, так что принимаю только прямые ссылки или исходный код.

1. Кто видел сампл, как сделать эдитор вроде вбшного
2. Кто знает как сделать технологию Drag'n'Drop в текстовом редакторе?
3. Как к PictureBox добавить скроллбары? Ну типа через сабклассинг, но нужен нормальный код, т.к. все, что я видел, - дерьмо(некоторыее оставляют бар всегда синим, даже когда не нужно, другие при нажатии кнопки End вылетают нах вместе с IDE)

ps Делаю редактор с блочным выделением

2. 'block move'
     a111           a11
     b222           b221
     c333   into    c332
     d444           d443
     e555           e554
                       5
3. 'block delete'
     a11            a1
     b221           b21
     c332   into    c32
     d443           d43
     e554           e54
        5             5

answer asap plz

Ответить

  Ответы Всего ответов: 15  

Номер ответа: 1
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #1 Добавлено: 24.07.07 11:51
2. А разве есть проблема?
3. SetWindowLong / GWL_STYLE / WS_VSCROL
Чтобы не вылетало "нах вместе с IDE", сабклассинг делай в ocx или activex dll.

Ответить

Номер ответа: 2
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #2 Добавлено: 24.07.07 12:22
(это я, меня какой-то редиска забанил на месяц)
2eugy 2. Ладно, забей
3. осх и длл недопустимы, необходим сплошной экзе. во-вторых нормальные коды существуют, однако я потерял библу с ними. в-третьих я попросил не разводить флейм по поводу "как можно сделать лучше". мне нужен код.
SetWindowLong / GWL_STYLE / WS_VSCROL это лишь 1/100 всего кода. И применить его можно 20 разными методами. Это неконкретный ответ.

Ответить

Номер ответа: 3
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #3 Добавлено: 24.07.07 14:11
http://slil.ru/24659402 - то что я сделал
попробуйте потягать форму во все стороны.
горизонтальный исчезает(хотелось бы чтобы становился серым)
вертикальный моргает
ужос.

Ответить

Номер ответа: 4
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #4 Добавлено: 24.07.07 14:43
From http://vbaccelerator.com/home/VB/Code/Libraries/Subclassing/Adding_Scroll_Bars_To_Forms__PictureBoxes_and_UserControls/article.asp

Note that the actual Max value of the scroll bar is actually equal to the nMax value plus the nPage value, so when modifying the LargeChange or Max value you have to take this into account.

Eugy, че ты там сказал? =) Если такой умный, че не сказал об этом )))

Ответить

Номер ответа: 5
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #5 Добавлено: 24.07.07 15:01

Case WM_SIZE
  if nadobloc then
  mVSI.Mask = SIF_DISABLENOSCROLL
  SetScrollInfo mhWnd, SB_HORZ, mHSI, True

Только убери бога ради mHSI из public, обьявляй прямо перед использованием, а то отследить - ну просто нет сил.

А если две PictureBox? Будешь добавлять еще одну процедуру?

Ответить

Номер ответа: 6
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #6 Добавлено: 24.07.07 15:04
Если такой умный, че не сказал об этом

Это ирония у тебя?

Ответить

Номер ответа: 7
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #7 Добавлено: 24.07.07 15:11
Мне нужен только 1 пикчербокс.
Сам попробуй, что предложил и убедись, что оно не работает.
Вот почему я говорю, что нужен сорс и ничего боле.
Это Почти ирония, если бы не было горькой правдой.
Вот код, который вдобавок юзает длл, щас попытаюсь вылечить. Оцени что такое написать этот кусок кода за 24 часа.

Option Explicit

Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128      '  Maintenance string for PSS usage
End Type

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function RegisterWindowMessage Lib "user32" Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Long, ByVal fuWinIni As Long) As Long

'private declare function InitializeFlatSB(HWND) as long
Private Declare Function InitialiseFlatSB Lib "comctl32.dll" Alias "InitializeFlatSB" (ByVal lHWnd As Long) As Long

' Scroll bar:
Private Type SCROLLINFO
    cbSize As Long
    fMask As Long
    nMin As Long
    nMax As Long
    nPage As Long
    nPos As Long
    nTrackPos As Long
End Type
Private Declare Function SetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, lpcScrollInfo As SCROLLINFO, ByVal BOOL As Boolean) As Long
Private Declare Function GetScrollInfo Lib "user32" (ByVal hwnd As Long, ByVal n As Long, LPSCROLLINFO As SCROLLINFO) As Long
Private Declare Function GetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long) As Long
Private Declare Function GetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, lpMinPos As Long, lpMaxPos As Long) As Long
Private Declare Function SetScrollPos Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nPos As Long, ByVal bRedraw As Long) As Long
Private Declare Function SetScrollRange Lib "user32" (ByVal hwnd As Long, ByVal nBar As Long, ByVal nMinPos As Long, ByVal nMaxPos As Long, ByVal bRedraw As Long) As Long
    Private Const SB_BOTH = 3
    Private Const SB_BOTTOM = 7
    Private Const SB_CTL = 2
    Private Const SB_ENDSCROLL = 8
    Private Const SB_HORZ = 0
    Private Const SB_LEFT = 6
    Private Const SB_LINEDOWN = 1
    Private Const SB_LINELEFT = 0
    Private Const SB_LINERIGHT = 1
    Private Const SB_LINEUP = 0
    Private Const SB_PAGEDOWN = 3
    Private Const SB_PAGELEFT = 2
    Private Const SB_PAGERIGHT = 3
    Private Const SB_PAGEUP = 2
    Private Const SB_RIGHT = 7
    Private Const SB_THUMBPOSITION = 4
    Private Const SB_THUMBTRACK = 5
    Private Const SB_TOP = 6
    Private Const SB_VERT = 1

    Private Const SIF_RANGE = &H1
    Private Const SIF_PAGE = &H2
    Private Const SIF_POS = &H4
    Private Const SIF_DISABLENOSCROLL = &H8
    Private Const SIF_TRACKPOS = &H10
    Private Const SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS)

   Private Const ESB_DISABLE_BOTH = &H3
   Private Const ESB_ENABLE_BOTH = &H0
   
   Private Const SBS_SIZEGRIP = &H10&
   
Private Declare Function EnableScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wSBflags As Long, ByVal wArrows As Long) As Long
Private Declare Function ShowScrollBar Lib "user32" (ByVal hwnd As Long, ByVal wBar As Long, ByVal bShow As Long) As Long

' Non-client messages:
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_NCRBUTTONDOWN = &HA4
Private Const WM_NCMBUTTONDOWN = &HA7

' Hit test codes for scroll bars:
Private Const HTHSCROLL = 6
Private Const HTVSCROLL = 7

' Scroll bar messages:
Private Const WM_VSCROLL = &H115
Private Const WM_HSCROLL = &H114
Private Const WM_MOUSEWHEEL = &H20A

' Mouse wheel stuff:
Private Const WHEEL_DELTA = 120
Private Const WHEEL_PAGESCROLL = -1
Private Const SPI_GETWHEELSCROLLLINES = &H68

' Old school Wheel Mouse is not supported in this class.
' NT3.51 or Win95 only
'// Class name for MSWHEEL.EXE's invisible window
'// use FindWindow to get hwnd to MSWHEEL
Private Const MSH_MOUSEWHEEL = "MSWHEEL_ROLLMSG"
Private Const MSH_WHEELMODULE_CLASS = "MouseZ"
Private Const MSH_WHEELMODULE_TITLE = "Magellan MSWHEEL"
'// Apps need to call RegisterWindowMessage using the #defines
'// below to get the message numbers for:
'// 1) the message that can be sent to the MSWHEEL window to
'//    query if wheel support is active (MSH_WHEELSUPPORT)>
'// 2) the message to query for the number of scroll lines
'//    ;(MSH_SCROLL_LINES)
'//
'// To send a message to MSWheel window, use FindWindow with the #defines
'// for CLASS and TITLE above.  If FindWindow fails to find the MSWHEEL
'// window or the return from SendMessage is false, then Wheel support
'// is not currently available.
Private Const MSH_WHEELSUPPORT = "MSH_WHEELSUPPORT_MSG"
Private Const MSH_SCROLL_LINES = "MSH_SCROLL_LINES_MSG"

' Flat scroll bars:
Private Const WSB_PROP_CYVSCROLL = &H1&
Private Const WSB_PROP_CXHSCROLL = &H2&
Private Const WSB_PROP_CYHSCROLL = &H4&
Private Const WSB_PROP_CXVSCROLL = &H8&
Private Const WSB_PROP_CXHTHUMB = &H10&
Private Const WSB_PROP_CYVTHUMB = &H20&
Private Const WSB_PROP_VBKGCOLOR = &H40&
Private Const WSB_PROP_HBKGCOLOR = &H80&
Private Const WSB_PROP_VSTYLE = &H100&
Private Const WSB_PROP_HSTYLE = &H200&
Private Const WSB_PROP_WINSTYLE = &H400&
Private Const WSB_PROP_PALETTE = &H800&
Private Const WSB_PROP_MASK = &HFFF&

Private Const FSB_FLAT_MODE = 2&
Private Const FSB_ENCARTA_MODE = 1&
Private Const FSB_REGULAR_MODE = 0&

Private Declare Function FlatSB_EnableScrollBar Lib "comctl32.dll" (ByVal hwnd As Long, ByVal int2 As Long, ByVal UINT3 As Long) As Long
Private Declare Function FlatSB_ShowScrollBar Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal fRedraw As Boolean) As Long

Private Declare Function FlatSB_GetScrollRange Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal LPINT1 As Long, ByVal LPINT2 As Long) As Long
Private Declare Function FlatSB_GetScrollInfo Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, LPSCROLLINFO As SCROLLINFO) As Long
Private Declare Function FlatSB_GetScrollPos Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long) As Long
Private Declare Function FlatSB_GetScrollProp Lib "comctl32.dll" (ByVal hwnd As Long, ByVal propIndex As Long, ByVal LPINT As Long) As Long

Private Declare Function FlatSB_SetScrollPos Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal pos As Long, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_SetScrollInfo Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, LPSCROLLINFO As SCROLLINFO, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_SetScrollRange Lib "comctl32.dll" (ByVal hwnd As Long, ByVal code As Long, ByVal Min As Long, ByVal Max As Long, ByVal fRedraw As Boolean) As Long
Private Declare Function FlatSB_SetScrollProp Lib "comctl32.dll" (ByVal hwnd As Long, ByVal index As Long, ByVal newValue As Long, ByVal fRedraw As Boolean) As Long

Private Declare Function InitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As Long) As Long
Private Declare Function UninitializeFlatSB Lib "comctl32.dll" (ByVal hwnd As Long) As Long


' Message response:
Implements ISubclass
Private m_emr As EMsgResponse

' Initialisation state:
Private m_bInitialised As Boolean

' Orientation
Public Enum EFSOrientationConstants
    efsoHorizontal
    efsoVertical
    efsoBoth
End Enum
Private m_eOrientation As EFSOrientationConstants

' Style
Public Enum EFSStyleConstants
    efsRegular = FSB_REGULAR_MODE
    efsEncarta = FSB_ENCARTA_MODE
    efsFlat = FSB_FLAT_MODE
End Enum
Private m_eStyle As EFSStyleConstants
' Bars:
Public Enum EFSScrollBarConstants
   efsHorizontal = SB_HORZ
   efsVertical = SB_VERT
End Enum

' Can we have flat scroll bars?
Private m_bNoFlatScrollBars As Boolean

' hWnd we're adding scroll bars too:
Private m_hWnd As Long

' Small change amount
Private m_lSmallChangeHorz As Long
Private m_lSmallChangeVert As Long
' Enabled:
Private m_bEnabledHorz As Boolean
Private m_bEnabledVert As Boolean
' Visible
Private m_bVisibleHorz As Boolean
Private m_bVisibleVert As Boolean

' Number of lines to scroll for each wheel click:
Private m_lWheelScrollLines  As Long

Public Event ScrollClick(eBar As EFSScrollBarConstants, eButton As MouseButtonConstants)
Public Event Scroll(eBar As EFSScrollBarConstants)
Public Event Change(eBar As EFSScrollBarConstants)
Public Event MouseWheel(eBar As EFSScrollBarConstants, lAmount As Long)

Public Property Get Visible(ByVal eBar As EFSScrollBarConstants) As Boolean
   If (eBar = efsHorizontal) Then
      Visible = m_bVisibleHorz
   Else
      Visible = m_bVisibleVert
   End If
End Property
Public Property Let Visible(ByVal eBar As EFSScrollBarConstants, ByVal bState As Boolean)
   If (eBar = efsHorizontal) Then
      m_bVisibleHorz = bState
   Else
      m_bVisibleVert = bState
   End If
   If (m_bNoFlatScrollBars) Then
      ShowScrollBar m_hWnd, eBar, Abs(bState)
   Else
      FlatSB_ShowScrollBar m_hWnd, eBar, Abs(bState)
   End If
End Property

Public Property Get Orientation() As EFSOrientationConstants
   Orientation = m_eOrientation
End Property

Public Property Let Orientation(ByVal eOrientation As EFSOrientationConstants)
   m_eOrientation = eOrientation
   pSetOrientation
End Property

Private Sub pSetOrientation()
   ShowScrollBar m_hWnd, SB_HORZ, Abs((m_eOrientation = efsoBoth) Or (m_eOrientation = efsoHorizontal))
   ShowScrollBar m_hWnd, SB_VERT, Abs((m_eOrientation = efsoBoth) Or (m_eOrientation = efsoVertical))
End Sub

Private Sub pGetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As SCROLLINFO, ByVal fMask As Long)
Dim lO As Long
    
    lO = eBar
    tSI.fMask = fMask
    tSI.cbSize = LenB(tSI)
    
    If (m_bNoFlatScrollBars) Then
        GetScrollInfo m_hWnd, lO, tSI
    Else
        FlatSB_GetScrollInfo m_hWnd, lO, tSI
    End If

End Sub
Private Sub pLetSI(ByVal eBar As EFSScrollBarConstants, ByRef tSI As SCROLLINFO, ByVal fMask As Long)
Dim lO As Long
        
    lO = eBar
    tSI.fMask = fMask
    tSI.cbSize = LenB(tSI)
    
    If (m_bNoFlatScrollBars) Then
        SetScrollInfo m_hWnd, lO, tSI, True
    Else
        FlatSB_SetScrollInfo m_hWnd, lO, tSI, True
    End If
    
End Sub

Public Property Get Style() As EFSStyleConstants
   Style = m_eStyle
End Property
Public Property Let Style(ByVal eStyle As EFSStyleConstants)
Dim lR As Long
   If (eStyle <> efsRegular) Then
      If (m_bNoFlatScrollBars) Then
         ' can't do it..
         Debug.Print "Can't set non-regular style mode on this system - COMCTL32.DLL version < 4.71."
         Exit Property
      End If
   End If
   If (m_eOrientation = efsoHorizontal) Or (m_eOrientation = efsoBoth) Then
      lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_HSTYLE, eStyle, True)
   End If
   If (m_eOrientation = efsoVertical) Or (m_eOrientation = efsoBoth) Then
      lR = FlatSB_SetScrollProp(m_hWnd, WSB_PROP_VSTYLE, eStyle, True)
   End If
   m_eStyle = eStyle
End Property

Public Property Get SmallChange(ByVal eBar As EFSScrollBarConstants) As Long
   If (eBar = efsHorizontal) Then
      SmallChange = m_lSmallChangeHorz
   Else
      SmallChange = m_lSmallChangeVert
   End If
End Property
Public Property Let SmallChange(ByVal eBar As EFSScrollBarConstants, ByVal lSmallChange As Long)
   If (eBar = efsHorizontal) Then
      m_lSmallChangeHorz = lSmallChange
   Else
      m_lSmallChangeVert = lSmallChange
   End If
End Property
Public Property Get Enabled(ByVal eBar As EFSScrollBarConstants) As Boolean
   If (eBar = efsHorizontal) Then
      Enabled = m_bEnabledHorz
   Else
      Enabled = m_bEnabledVert
   End If
End Property
Public Property Let Enabled(ByVal eBar As EFSScrollBarConstants, ByVal bEnabled As Boolean)
Dim lO As Long
Dim lF As Long
        
   lO = eBar
   If (bEnabled) Then
      lF = ESB_ENABLE_BOTH
   Else
      lF = ESB_DISABLE_BOTH
   End If
   If (m_bNoFlatScrollBars) Then
      EnableScrollBar m_hWnd, lO, lF
   Else
      FlatSB_EnableScrollBar m_hWnd, lO, lF
   End If
    
End Property
Public Property Get Min(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_RANGE
    Min = tSI.nMin
End Property
Public Property Get Max(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_RANGE Or SIF_PAGE
    Max = tSI.nMax - tSI.nPage
End Property
Public Property Get Value(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_POS
    Value = tSI.nPos
End Property
Public Property Get LargeChange(ByVal eBar As EFSScrollBarConstants) As Long
Dim tSI As SCROLLINFO
    pGetSI eBar, tSI, SIF_PAGE
    LargeChange = tSI.nPage
End Property
Public Property Let Min(ByVal eBar As EFSScrollBarConstants, ByVal iMin As Long)
Dim tSI As SCROLLINFO
    tSI.nMin = iMin
    tSI.nMax = Max(eBar) + LargeChange(eBar)
    pLetSI eBar, tSI, SIF_RANGE
End Property
Public Property Let Max(ByVal eBar As EFSScrollBarConstants, ByVal iMax As Long)
Dim tSI As SCROLLINFO
    tSI.nMax = iMax + LargeChange(eBar)
    tSI.nMin = Min(eBar)
    pLetSI eBar, tSI, SIF_RANGE
    pRaiseEvent eBar, False
End Property
Public Property Let Value(ByVal eBar As EFSScrollBarConstants, ByVal iValue As Long)
Dim tSI As SCROLLINFO
    If (iValue <> Value(eBar)) Then
        tSI.nPos = iValue
        pLetSI eBar, tSI, SIF_POS
        pRaiseEvent eBar, False
    End If
End Property
Public Property Let LargeChange(ByVal eBar As EFSScrollBarConstants, ByVal iLargeChange As Long)
Dim tSI As SCROLLINFO
Dim lCurMax As Long
Dim lCurLargeChange As Long
    
   pGetSI eBar, tSI, SIF_ALL
   tSI.nMax = tSI.nMax - tSI.nPage + iLargeChange
   tSI.nPage = iLargeChange
   pLetSI eBar, tSI, SIF_PAGE Or SIF_RANGE
End Property
Public Property Get CanBeFlat() As Boolean
   CanBeFlat = Not (m_bNoFlatScrollBars)
End Property
Private Sub pCreateScrollBar()
Dim lR As Long
Dim lStyle As Long
Dim hParent As Long

   ' Just checks for flag scroll bars...
   On Error Resume Next
   lR = InitialiseFlatSB(m_hWnd)
   If (Err.Number <> 0) Then
       'Can't find DLL entry point InitializeFlatSB in COMCTL32.DLL
       ' Means we have version prior to 4.71
       ' We get standard scroll bars.
       m_bNoFlatScrollBars = True
   Else
      Style = m_eStyle
   End If
   
End Sub

Public Sub Create(ByVal hWndA As Long)
   pClearUp
   m_hWnd = hWndA
   pCreateScrollBar
   pAttachMessages
End Sub

Private Sub pClearUp()
   If m_hWnd <> 0 Then
      On Error Resume Next
      ' Stop flat scroll bar if we have it:
      If Not (m_bNoFlatScrollBars) Then
         UninitializeFlatSB m_hWnd
      End If
    
      On Error GoTo 0
      ' Remove subclass:
      ;DetachMessage Me, m_hWnd, WM_HSCROLL
      ;DetachMessage Me, m_hWnd, WM_VSCROLL
      ;DetachMessage Me, m_hWnd, WM_MOUSEWHEEL
      ;DetachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
      ;DetachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
      ;DetachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
   End If
   m_hWnd = 0
   m_bInitialised = False
End Sub
Private Sub pAttachMessages()
   If (m_hWnd <> 0) Then
      AttachMessage Me, m_hWnd, WM_HSCROLL
      AttachMessage Me, m_hWnd, WM_VSCROLL
      AttachMessage Me, m_hWnd, WM_MOUSEWHEEL
      AttachMessage Me, m_hWnd, WM_NCLBUTTONDOWN
      AttachMessage Me, m_hWnd, WM_NCMBUTTONDOWN
      AttachMessage Me, m_hWnd, WM_NCRBUTTONDOWN
      SystemParametersInfo SPI_GETWHEELSCROLLLINES, _
            0, m_lWheelScrollLines, 0
      If (m_lWheelScrollLines <= 0) Then
         m_lWheelScrollLines = 3
      End If
      m_bInitialised = True
   End If
End Sub

Private Sub Class_Initialize()
   m_lSmallChangeHorz = 1
   m_lSmallChangeVert = 1
   m_eStyle = efsRegular
   m_eOrientation = efsoBoth
End Sub

Private Sub Class_Terminate()
   pClearUp
End Sub

Private Property Let ISubclass_MsgResponse(ByVal RHS As EMsgResponse)
   '
End Property

Private Property Get ISubclass_MsgResponse() As EMsgResponse
   ISubclass_MsgResponse = emrPostProcess
End Property

Private Function ISubclass_WindowProc(ByVal hwnd As Long, ByVal iMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lScrollCode As Long
Dim tSI As SCROLLINFO
Dim lV As Long, lSC As Long
Dim eBar As EFSScrollBarConstants
Dim zDelta As Long
Dim lDelta As Long
Dim wMKeyFlags As Long

   Select Case iMsg
   Case WM_MOUSEWHEEL
      ' Low-word of wParam indicates whether virtual keys
      ' are down
      wMKeyFlags = wParam And &HFFFF&
      ' High order word is the distance the wheel has been rotated,
      ' in multiples of WHEEL_DELTA:
      If (wParam And &H8000000) Then
         ' Towards the user:
         zDelta = &H8000& - (wParam And &H7FFF0000) \ &H10000
      Else
         ' Away from the user:
         zDelta = -((wParam And &H7FFF0000) \ &H10000)
      End If
      lDelta = (zDelta \ WHEEL_DELTA) * SmallChange(efsVertical) * m_lWheelScrollLines
      eBar = efsVertical
      RaiseEvent MouseWheel(eBar, lDelta)
      If Not (lDelta = 0) Then
         Value(eBar) = Value(eBar) + lDelta
         ISubclass_WindowProc = 1
      End If
   
   Case WM_VSCROLL, WM_HSCROLL
      If (iMsg = WM_HSCROLL) Then
         eBar = efsHorizontal
      Else
         eBar = efsVertical
      End If
      lScrollCode = (wParam And &HFFFF&;)
      Select Case lScrollCode
      Case SB_THUMBTRACK
         ' Is vertical/horizontal?
         pGetSI eBar, tSI, SIF_TRACKPOS
         Value(eBar) = tSI.nTrackPos
         pRaiseEvent eBar, True
         
      Case SB_LEFT, SB_TOP
         Value(eBar) = Min(eBar)
         pRaiseEvent eBar, False
         
      Case SB_RIGHT, SB_BOTTOM
         Value(eBar) = Max(eBar)
         pRaiseEvent eBar, False
          
      Case SB_LINELEFT, SB_LINEUP
         'Debug.Print "Line"
         lV = Value(eBar)
         If (eBar = efsHorizontal) Then
            lSC = m_lSmallChangeHorz
         Else
            lSC = m_lSmallChangeVert
         End If
         If (lV - lSC < Min(eBar)) Then
            Value(eBar) = Min(eBar)
         Else
            Value(eBar) = lV - lSC
         End If
         pRaiseEvent eBar, False
         
      Case SB_LINERIGHT, SB_LINEDOWN
          'Debug.Print "Line"
         lV = Value(eBar)
         If (eBar = efsHorizontal) Then
            lSC = m_lSmallChangeHorz
         Else
            lSC = m_lSmallChangeVert
         End If
         If (lV + lSC > Max(eBar)) Then
            Value(eBar) = Max(eBar)
         Else
            Value(eBar) = lV + lSC
         End If
         pRaiseEvent eBar, False
          
      Case SB_PAGELEFT, SB_PAGEUP
         Value(eBar) = Value(eBar) - LargeChange(eBar)
         pRaiseEvent eBar, False
         
      Case SB_PAGERIGHT, SB_PAGEDOWN
         Value(eBar) = Value(eBar) + LargeChange(eBar)
         pRaiseEvent eBar, False
         
      Case SB_ENDSCROLL
         pRaiseEvent eBar, False
         
      End Select
      
   Case WM_NCLBUTTONDOWN, WM_NCRBUTTONDOWN
      Dim eBtn As MouseButtonConstants
      eBtn = IIf(iMsg = WM_NCLBUTTONDOWN, vbLeftButton, vbRightButton)
      If wParam = HTVSCROLL Then
         RaiseEvent ScrollClick(efsHorizontal, eBtn)
      ElseIf wParam = HTHSCROLL Then
         RaiseEvent ScrollClick(efsVertical, eBtn)
      End If
      
         
   End Select

End Function

Private Function pRaiseEvent(ByVal eBar As EFSScrollBarConstants, ByVal bScroll As Boolean)
Static s_lLastValue(0 To 1) As Long
   If (Value(eBar) <> s_lLastValue(eBar)) Then
      If (bScroll) Then
         RaiseEvent Scroll(eBar)
      Else
         RaiseEvent Change(eBar)
      End If
      s_lLastValue(eBar) = Value(eBar)
   End If
   
End Function



Ответить

Номер ответа: 8
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #8 Добавлено: 24.07.07 15:23
Если ты насчет SetWindowLong, то
MSDN:
if you change any of the frame styles, you must call SetWindowPos with the SWP_FRAMECHANGED flag for the cache to be updated properly.


SetWindowLong hwndpic, GWL_STYLE, GetWindowLong(hwndpic, GWL_STYLE) Or WS_VSCROLL
SetWindowPos hwndpic, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE


Оцени что такое написать этот кусок кода за 24 часа

Не поразил.

Ответить

Номер ответа: 9
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #9 Добавлено: 24.07.07 15:41
p.s.
И вообще, как-то несолидно:
http://bbs.vbstreets.ru/viewtopic.php?t=33829&sid=2ab4ce166341430660d124e54abb636e

Ответить

Номер ответа: 10
Автор ответа:
 Взломщик



Вопросов: 0
Ответов: 18
 Профиль | | #10 Добавлено: 24.07.07 19:21
Все Февер ето на всю жизнь бан здесь авторазбан не работает поверь мне.Че то павел не в духе всех банит...

Ответить

Номер ответа: 11
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #11 Добавлено: 24.07.07 20:07
ага, бан на всю жизнь длиной в месяц =) не гони, а для флуда есть раздел оффтоп. Прошу заткнуться.

Ответить

Номер ответа: 12
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #12 Добавлено: 25.07.07 01:14
Я щас _страшно злой_. Почему нельзя ответить сорсом и бесплатно? Я ушол на вбстритс и наверное не вернусь. Задрали.
И вообще, как-то несолидно:

Ты неверно понял. Прикинь, что такое написать такой шмат кода за 24 часа (срок который мне дан)? Если все, что ты когда-либо знал - SetWindowLong / GWL_STYLE / WS_VSCROL. Хорошо, мне там подсказали. Извиняюсь за неоднозначность.

Ответить

Номер ответа: 13
Автор ответа:
 EUGY



Вопросов: 0
Ответов: 454
 Профиль | | #13 Добавлено: 25.07.07 05:57
Дружище udpn. Не нервничай.) Я был уверен, что примеров по скролам полно и ты их найдешь сам.
Моих же знаний хватит написать все это самому часа за три. Но тогда это работа.
Насчет безопасного сабклассинга из IDE. Попадалась как-то на глаза вешь, перехват событий от wndclass_desked_gsk, но опять же реализовано отдельым com-объектом.

Ответить

Номер ответа: 14
Автор ответа:
 Nash Bridges



Вопросов: 5
Ответов: 139
 Профиль | | #14 Добавлено: 25.07.07 19:23
Я ушол на вбстритс и наверное не вернусь. Задрали


на вбстритс тебя за такой подход к общению через 5 минут забанят.

Ответить

Номер ответа: 15
Автор ответа:
 udpn



Вопросов: 2
Ответов: 45
 Профиль | | #15 Добавлено: 25.07.07 21:21
2Nash Bridges
а ну и пофиг, буду совсем фрилансером. а подход к общению такой ибо совсем задрали. я уже писал плстов 10 и ни одного ответа не получил. что ищщо думать? на вбстритс мне дали классную сцылку, я код исправил для моих нужд за 15 минут и счастлив

Ответить

Страница: 1 |

Поиск по форуму



© Copyright 2002-2011 VBNet.RU | Пишите нам