Sie sind aktuell nicht angemeldet.

Funktionen: Einloggen  |  Neu registrieren  |  Suchen

Re: Wichtige Frage,für Profis
Autor: Mac
Datum: 21.11.02 20:33
Das ist sehr einfach! Pass auf beim Abtippen!!! Für den Formcode machste das Notepad auf (Copy/Paste und dann als Form1.frm saven!): VERSION 5.00 Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX" Begin VB.Form fTestDrag BorderStyle = 4 'Fixed ToolWindow Caption = "Test Drag and Drop Function Only" ClientHeight = 5655 ClientLeft = 45 ClientTop = 285 ClientWidth = 3570 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 5655 ScaleWidth = 3570 ShowInTaskbar = 0 'False StartUpPosition = 2 'CenterScreen Begin MSComctlLib.TreeView oTree Height = 5475 Left = 105 TabIndex = 0 Top = 105 Width = 3375 _ExtentX = 5953 _ExtentY = 9657 _Version = 393217 Style = 7 Appearance = 1 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "Tahoma" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty End Begin MSComctlLib.ImageList ilDialog Left = 2730 Top = 0 _ExtentX = 1005 _ExtentY = 1005 BackColor = -2147483643 ImageWidth = 16 ImageHeight = 16 MaskColor = 16777215 _Version = 393216 BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} NumListImages = 8 BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":0000 Key = "" EndProperty BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":059A Key = "" EndProperty BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":0B34 Key = "" EndProperty BeginProperty ListImage4 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":10CE Key = "" EndProperty BeginProperty ListImage5 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":1668 Key = "" EndProperty BeginProperty ListImage6 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":1C02 Key = "" EndProperty BeginProperty ListImage7 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":1F1C Key = "" EndProperty BeginProperty ListImage8 {2C247F27-8591-11D1-B16A-00C0F0283628} Picture = "Form1.frx":2236 Key = "" EndProperty EndProperty End End Attribute VB_Name = "fTestDrag" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit '=========================================================================== ' Debugging... Saves adding the debug statements to the form events ' #Const DEBUGMODE = 0 '## 0=No debug ' 1=debug #Const MOUSEEVENTS = 0 '## 0=No mouse events ' 1=Mouse Up & Mouse Down ' 2=All Mouse events #If DEBUGMODE = 1 Then Private dbgFormName As String #End If '=========================================================================== ' Private: Variables and Declarations ' Private Enum eCodeScrollView '## Scroll Treeview [Home] = 0 [Page Up] = 1 [Up] = 2 [Down] = 3 [Page Down] = 4 [End] = 5 [Left] = 6 [Page Left] = 7 [Line Left] = 8 [Line Right] = 9 [Page Right] = 10 [Right] = 11 End Enum Private moDragNode As MSComctlLib.Node Private moInDrag As MSComctlLib.Node Private mbDragEnabled As Boolean Private mbStartDrag As Boolean Private mbInDrag As Boolean Private mlNodeHeight As Long Private mlDragExpandTime As Long Private mlDragScrollTime As Long Private mlAutoScroll As Long '## Distance in which auto-scrolling happens Private mszDrag As Size '## X and Y distance cursor moves before dragging begins, in pixels Private mptBtnDown As POINTAPI Private WithEvents moDragExpand As XTimer Attribute moDragExpand.VB_VarHelpID = -1 Private WithEvents moDragScroll As XTimer Attribute moDragScroll.VB_VarHelpID = -1 '=========================================================================== ' Private: APIs ' Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As Any) As Long ' lpPoint As POINTAPI) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function GetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal fnBar As SB_Type, lpsi As SCROLLINFO) As Boolean Private Declare Function PtInRect Lib "user32" (lprc As RECT, ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Enum RectFlags rfLeft = &H1 rfTop = &H2 rfRight = &H4 rfBottom = &H8 End Enum Private Enum ScrollDirectionFlags sdLeft = &H1 sdUp = &H2 sdRight = &H4 sdDown = &H8 End Enum Private Enum SB_Type SB_HORZ = 0 SB_VERT = 1 SB_CTL = 2 SB_BOTH = 3 End Enum Private Enum SIF_Mask SIF_RANGE = &H1 SIF_PAGE = &H2 SIF_POS = &H4 SIF_DISABLENOSCROLL = &H8 SIF_TRACKPOS = &H10 SIF_ALL = (SIF_RANGE Or SIF_PAGE Or SIF_POS Or SIF_TRACKPOS) End Enum Private Type SCROLLINFO cbSize As Long fMask As SIF_Mask nMin As Long nMax As Long nPage As Long nPos As Long nTrackPos As Long End Type Private Type Size cx As Long cy As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI ' pt x As Long y As Long End Type Private Const TV_FIRST As Long = &H1100 Private Const TVM_DELETEITEM As Long = (TV_FIRST + 1) Private Const TVM_GETITEMRECT As Long = (TV_FIRST + 4) Private Const TVM_SETIMAGELIST As Long = (TV_FIRST + 9) Private Const TVM_GETNEXTITEM As Long = (TV_FIRST + 10) Private Const TVM_SELECTITEM As Long = (TV_FIRST + 11) Private Const TVM_GETITEM As Long = (TV_FIRST + 12) Private Const TVM_SETITEM As Long = (TV_FIRST + 13) Private Const TVM_HITTEST As Long = (TV_FIRST + 17) Private Const TVM_CREATEDRAGIMAGE As Long = (TV_FIRST + 18) '## TVM_GETNEXTITEM wParam values Public Enum TVGN_Flags TVGN_ROOT = &H0 TVGN_NEXT = &H1 TVGN_PREVIOUS = &H2 TVGN_PARENT = &H3 TVGN_CHILD = &H4 TVGN_FIRSTVISIBLE = &H5 TVGN_NEXTVISIBLE = &H6 TVGN_PREVIOUSVISIBLE = &H7 TVGN_DROPHILITE = &H8 TVGN_CARET = &H9 '#If (WIN32_IE >= &H400) Then ' >= Comctl32.dll v4.71 TVGN_LASTVISIBLE = &HA '#End If End Enum Private Const GWL_STYLE As Long = (-16) Private Const SM_CXDRAG As Long = &H44 Private Const SM_CYDRAG As Long = &H45 '--------------------------------------------------------------------------- ' Scroll Bar Commands Private Const SB_LINEUP As Long = 0 Private Const SB_LINELEFT As Long = 0 Private Const SB_LINEDOWN As Long = 1 Private Const SB_LINERIGHT As Long = 1 Private Const SB_PAGEUP As Long = 2 Private Const SB_PAGELEFT As Long = 2 Private Const SB_PAGEDOWN As Long = 3 Private Const SB_PAGERIGHT As Long = 3 Private Const SB_THUMBPOSITION As Long = 4 Private Const SB_THUMBTRACK As Long = 5 Private Const SB_TOP As Long = 6 Private Const SB_LEFT As Long = 6 Private Const SB_BOTTOM As Long = 7 Private Const SB_RIGHT As Long = 7 Private Const SB_ENDSCROLL As Long = 8 Private Const WM_HSCROLL As Long = &H114 Private Const WM_VSCROLL As Long = &H115 Private Const WS_HSCROLL As Long = &H100000 Private Const WS_VSCROLL As Long = &H200000 Private Declare Function SendMessageAny Lib "user32" Alias "SendMessageA" _ (ByVal hWnd As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ lParam As Any) As Long Private Declare Function GetScrollPos Lib "user32" (ByVal hWnd As Long, ByVal nBar As Long) As Long '=========================================================================== ' Form Events ' Private Sub Form_Load() #If DEBUGMODE = 1 Then dbgFormName = Me.Name #End If Debug.Print vbCrLf + "=========================================" + _ vbCrLf + " Started : " + Time$ + _ vbCrLf + "-----------------------------------------" pInitTree Set moDragExpand = New XTimer Set moDragScroll = New XTimer '*********************************** '** PROTOTYPING PURPOSES ONLY Dim bState As Boolean Dim RC As RECT With oTree bState = .Scroll .Scroll = False mlNodeHeight = .Height \ .GetVisibleCount .Scroll = bState mlDragExpandTime = 1000 mlDragScrollTime = 200 mbDragEnabled = True RC.Left = SendMessageAny(.hWnd, TVM_GETNEXTITEM, ByVal TVGN_ROOT, ByVal 0&) If SendMessageAny(.hWnd, TVM_GETITEMRECT, ByVal 1, RC) Then mlAutoScroll = (RC.Bottom - RC.Top) * 2 Else mlAutoScroll = 32 End If End With '*********************************** mszDrag.cx = GetSystemMetrics(SM_CXDRAG) mszDrag.cy = GetSystemMetrics(SM_CYDRAG) moDragExpand.Interval = mlDragExpandTime moDragScroll.Interval = mlDragScrollTime End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Debug.Print vbCrLf + "-----------------------------------------" + _ vbCrLf + " Finished : " + Time$ + _ vbCrLf + "=========================================" Set moDragExpand = Nothing Set moDragScroll = Nothing End Sub Private Sub moDragScroll_Tick() ' #If DEBUGMODE = 1 Then ' Debug.Print dbgFormName; "::moDragScroll -> Tick!" Debug.Print "Drag Scroll -> Tick!" ' #End If Dim pt As POINTAPI Dim rcClient As RECT Dim dwRectFlags As RectFlags Dim dwScrollFlags As ScrollDirectionFlags If mbInDrag = False Then moDragScroll.Enabled = False Exit Sub End If ' '## Get the cursor postion in TreeView client coords ' With oTree GetCursorPos pt ScreenToClient .hWnd, pt GetClientRect .hWnd, rcClient End With ' '## If the cursor is within an auto scroll region in the TreeView's client area... ' dwRectFlags = PtInRectRegion(rcClient, mlAutoScroll, pt) If dwRectFlags Then ' '## Determine which direction the TreeView can be scrolled... ' dwScrollFlags = IsWindowScrollable(oTree.hWnd) ' '## If the cursor is within the respective drag region specified by the ' mlAutoScroll distance, and if the TreeView can be scrolled ' in that direction, send the TreeView that respective scroll message. ' Select Case True Case (dwRectFlags And rfLeft) And (dwScrollFlags And sdLeft) 'Debug.Print "Left" ScrollView [Line Left] Case (dwRectFlags And rfRight) And (dwScrollFlags And sdRight) 'Debug.Print "Right" ScrollView [Line Right] Case (dwRectFlags And rfTop) And (dwScrollFlags And sdUp) 'Debug.Print "Up" ScrollView [Up] Case (dwRectFlags And rfBottom) And (dwScrollFlags And sdDown) 'Debug.Print "Down" ScrollView [Down] Case Else moDragScroll.Enabled = False End Select End If End Sub Private Sub moDragExpand_Tick() ' #If DEBUGMODE = 1 Then ' Debug.Print dbgFormName; "::moDragExpand -> Tick!" Debug.Print "Drag Expand -> Tick!" ' #End If With oTree Select Case True Case (.DropHighlight Is Nothing), (moDragNode Is Nothing) '## Avoid possible error - should not be here! But it does happen. '!! Zhu, Exit Sub can't go here as we need to disable the timer ' first. More effecient code is to do nothing here. Case (.DropHighlight.Children > 0) And (.DropHighlight.Expanded = False) .DropHighlight.Expanded = True End Select End With moDragExpand.Enabled = False End Sub '=========================================================================== ' otree Events ' Private Sub otree_DragDrop(Source As Control, x As Single, y As Single) #If DEBUGMODE = 1 Then Debug.Print dbgFormName; ":ragDrop -> Source="; Source.Name; " X="; CStr(x); " Y="; CStr(y) #End If If mbDragEnabled Then With oTree .DropHighlight = .HitTest(x, y) If Not (.DropHighlight Is Nothing) Then '## Did we drop a node? If moDragNode <> .DropHighlight Then '## Yes. Did we drag the node onto itself? 'Debug.Print "Node " + moDragNode + " dropped on otree:" + .DropHighlight.Text 'RaiseEvent Dropped(moDragNode, .DropHighlight) '## Notify programmer & Reset Dropped moDragNode, .DropHighlight End If End If '## Reset Set .DropHighlight = Nothing Set moDragNode = Nothing mbInDrag = False mbStartDrag = False '.Drag vbEndDrag '!! Moved to otree_MouseUp End With End If End Sub Private Sub otree_DragOver(Source As Control, x As Single, y As Single, State As Integer) #If DEBUGMODE = 1 Then Debug.Print dbgFormName; ":ragOver -> Source="; Source.Name; " X="; CStr(x); " Y="; CStr(y) #End If If mbDragEnabled Then With oTree Set .DropHighlight = .HitTest(x, y) If .DropHighlight Is Nothing Then .DragIcon = LoadPicture(App.Path + "\no_m.CUR") Else .DragIcon = moDragNode.CreateDragImage End If End With pDoDrag End If End Sub Private Sub otree_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) #If DEBUGMODE = 1 Then #If MOUSEEVENTS = 1 Or MOUSEEVENTS = 2 Then Debug.Print dbgFormName; "::MouseDown -> Button="; CStr(Button); " Shift="; CStr(Shift); " X="; CStr(x); " Y="; CStr(y) #End If #End If With oTree If mbDragEnabled Then '## Is drag'n'drop allowed? GetCursorPos mptBtnDown If Button = vbLeftButton Then Set moDragNode = .HitTest(x, y) '## Capture the node to be dragged End If End If End With End Sub Private Sub otree_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) #If DEBUGMODE = 1 Then #If MOUSEEVENTS = 2 Then Debug.Print dbgFormName; "::MouseMove -> Button="; CStr(Button); " Shift="; CStr(Shift); " X="; CStr(x); " Y="; CStr(y) #End If #End If Dim pt As POINTAPI On Error GoTo ErrorHandler '@@ v01.00.03 If mbDragEnabled Then '## Is drag'n'drop allowed? If Button = vbLeftButton Then '## Yes. Signal a Drag operation. With oTree If Not (.HitTest(x, y) Is Nothing) Then '## Do we have a node selected? If mbStartDrag = True Then mbInDrag = True '## Yes. Set the flag to true. '.DragIcon = moDragNode.CreateDragImage '!! Moved to otree_DragOver .Drag vbBeginDrag '## Signal VB to start drag operation. Else If Not (moDragNode Is Nothing) Then 'RaiseEvent StartDrag(moDragNode) '## Notify programmer starting drag operation GetCursorPos pt If (Abs(pt.x - mptBtnDown.x) >= mszDrag.cx) Or (Abs(pt.y - mptBtnDown.y) >= mszDrag.cy) Then StartDrag moDragNode 'Debug.Print "Start Drag with otree:" + moDragNode.Text mbStartDrag = True End If End If End If End If End With End If End If Exit Sub ErrorHandler: '@@ v01.00.03 mbInDrag = False '@@ End Sub Private Sub otree_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) #If DEBUGMODE = 1 Then #If MOUSEEVENTS = 1 Or MOUSEEVENTS = 2 Then Debug.Print dbgFormName; "::MouseUp -> Button="; CStr(Button); " Shift="; CStr(Shift); " X="; CStr(x); " Y="; CStr(y) #End If #End If mbStartDrag = False mbInDrag = False '******************************************** '** NOTE: ADDED TO SEE IF FIXES PROBLEM! ** '******************************************** oTree.Drag vbEndDrag '******************************************** moDragExpand.Enabled = False moDragScroll.Enabled = False End Sub Private Sub otree_NodeClick(ByVal Node As MSComctlLib.Node) #If DEBUGMODE = 1 Then Debug.Print dbgFormName; "::NodeClick" #End If End Sub '=========================================================================== ' Drag Events ' Private Sub StartDrag(DragNode As MSComctlLib.Node) Debug.Print "Start Dragging "; DragNode.Text End Sub Private Sub Dragging(DragNode As MSComctlLib.Node, DestNode As MSComctlLib.Node) Select Case True Case (moInDrag Is Nothing), moInDrag.Index <> DestNode.Index Set moInDrag = DestNode Debug.Print "Dragging"; DragNode.Text; " over "; DestNode.Text End Select End Sub Private Sub Dropped(DragNode As MSComctlLib.Node, DestNode As MSComctlLib.Node) Debug.Print "Dropped "; DragNode.Text; " on "; DestNode.Text If Not NodeMove(DestNode, DragNode) Then ' '## Problems with moving the node. Most likely a root node was dragged! ' MsgBox "Unable to move the selected node.", _ vbApplicationModal + vbExclamation + vbOKOnly, _ App.Title Else Debug.Print "-----------------------------------------" End If End Sub '=========================================================================== ' Internal Functions ' Private Function PtInRectRegion(RC As RECT, cxyRegion As Long, pt As POINTAPI) As RectFlags ' '## Returns a set of bit flags indicating whether the specified point resides in ' the specified size region with the perimeter of the specified rect. cxyRegion ' defines the rectangular region within rc, and must be a positive value Dim dwFlags As RectFlags If PtInRect(RC, pt.x, pt.y) Then dwFlags = (rfLeft And (pt.x <= (RC.Left + cxyRegion))) dwFlags = dwFlags Or (rfRight And (pt.x >= (RC.Right - cxyRegion))) dwFlags = dwFlags Or (rfTop And (pt.y <= (RC.Top + cxyRegion))) dwFlags = dwFlags Or (rfBottom And (pt.y >= (RC.Bottom - cxyRegion))) End If PtInRectRegion = dwFlags End Function Private Function IsWindowScrollable(hWnd As Long) As ScrollDirectionFlags ' '## Returns a set of bit flags indicating whether the specified ' window can be scrolled in any given direction. Dim si As SCROLLINFO Dim dwScrollFlags As ScrollDirectionFlags si.cbSize = Len(si) si.fMask = SIF_ALL ' '## Get the horizontal scrollbar's info (GetScrollInfo returns ' TRUE after a scrollbar has been added to a window, ' even if the respective style bit is not set...) ' If (GetWindowLong(hWnd, GWL_STYLE) And WS_HSCROLL) Then If GetScrollInfo(hWnd, SB_HORZ, si) Then dwScrollFlags = (sdLeft And (si.nPos > 0)) dwScrollFlags = dwScrollFlags Or (sdRight And (si.nPos < (((si.nMax - si.nMin) + 1) - si.nPage))) End If End If ' '## Get the vertical scrollbar's info. ' If (GetWindowLong(hWnd, GWL_STYLE) And WS_VSCROLL) Then If GetScrollInfo(hWnd, SB_VERT, si) Then dwScrollFlags = dwScrollFlags Or (sdUp And (si.nPos > 0)) dwScrollFlags = dwScrollFlags Or (sdDown And (si.nPos < (((si.nMax - si.nMin) + 1) - si.nPage))) End If End If IsWindowScrollable = dwScrollFlags End Function Private Sub pDoDrag() Dim pt As POINTAPI Dim rcClient As RECT Static lOldNdx As Long With oTree If mbStartDrag = True Then If mbInDrag = True Then ' '## If the cursor is still over same item as it was on the previous call, ' the cursor is over button, label, or icon of a collapsed parent item, ' start the auto expand timer, disable the timer otherwise. If Not (.DropHighlight Is Nothing) Then If lOldNdx <> .DropHighlight.Index Then If (.DropHighlight.Children > 0) And (.DropHighlight.Expanded = False) Then moDragExpand.Enabled = True Else moDragExpand.Enabled = False End If End If lOldNdx = .DropHighlight.Index End If ' '## If the window is scrollable, and the cursor is within that auto scroll ' distance, start the auto scroll timer, disable the timer otherwise. ' GetCursorPos pt ScreenToClient .hWnd, pt GetClientRect .hWnd, rcClient If (IsWindowScrollable(.hWnd) And PtInRectRegion(rcClient, mlAutoScroll, pt)) Then moDragScroll.Enabled = True Else moDragScroll.Enabled = False End If If Not (.DropHighlight Is Nothing) Then '## We're over a node 'Debug.Print "Node " + moDragNode.Text + " dragging over otree:" + .DropHighlight 'RaiseEvent Dragging(moDragNode, .DropHighlight) Dragging moDragNode, .DropHighlight End If End If End If End With End Sub Private Sub pInitTree() With oTree .Style = tvwTreelinesPlusMinusPictureText .LineStyle = tvwRootLines .Indentation = 10 .ImageList = ilDialog '.FullRowSelect = True .HideSelection = False .HotTracking = True With .Nodes Dim lLoop As Long For lLoop = 0 To 25 .Add , , Chr$(65 + lLoop), "Node " + Chr$(65 + lLoop), 1, 2 Next ' .Add , , "B", "Node B", 1, 2 ' .Add , , "C", "Node C", 1, 2 ' .Add , , "D", "Node D", 1, 2 ' .Add , , "E", "Node E", 1, 2 Dim oNode As MSComctlLib.Node Set oNode = .Add(, , "X1", "Node Item 1", 1, 2) oNode.Expanded = True For lLoop = 2 To 20 Set oNode = .Add(oTree.Nodes("X" + CStr(lLoop - 1)), _ tvwChild, _ "X" + CStr(lLoop), _ "Node Item " + CStr(lLoop), 1, 2) oNode.Expanded = True Next End With End With End Sub Private Function NodeMove(ParentNode As MSComctlLib.Node, _ ChildNode As MSComctlLib.Node, _ Optional ByVal bSelect As Boolean = True) As Boolean Dim lNDX As Long Dim lCount As Long Dim lLoop As Long Dim bRoot As Boolean With ChildNode If ParentNode = ChildNode Then '## Same node - therefore no point Exit Function End If If IsParentNode(ParentNode, ChildNode) Then '## Are we moving a parent node? If IsRootNode(ChildNode) Then '## Yes. Is it a root node? Exit Function '## Yes. Can't move a root node. End If '## move the children before moving the designated node lCount = .Children For lLoop = 1 To lCount lNDX = .Child.Index Set oTree.Nodes(lNDX).Parent = .Parent Next End If '## Force the ParentNode to be expanded before the move ParentNode.Expanded = True '@@ v01.00.03 '## Give the child a new parent Set .Parent = ParentNode If bSelect Then .EnsureVisible .Selected = bSelect End If End With NodeMove = True End Function Private Function IsParentNode(ChildNode As MSComctlLib.Node, _ ParentNode As MSComctlLib.Node) As Boolean '## Checks if one node is the parent of another. ' This is a recursive routine that steps down through ' the branches of the parent node. Dim lNDX As Long If ParentNode.Children Then '## Does the parent node have children? lNDX = ParentNode.Child.Index '## Yes, remember the first child Do '## Step through all child nodes If lNDX = ChildNode.Index Then '## is ChildNode the test node? IsParentNode = True '## ParentNode is the parent of ChildNode. Exit Do End If If IsParentNode(ChildNode, oTree.Nodes(lNDX)) Then '## Step down through the branches IsParentNode = True '## ParentNode is the parent of ChildNode. Exit Do End If If lNDX <> ParentNode.Child.LastSibling.Index Then '## Have we tested the last child node? lNDX = oTree.Nodes(lNDX).Next.Index '## No. Point to the next child node Else Exit Do '## Yes. End If Loop End If End Function Private Function IsRootNode(Node As MSComctlLib.Node) As Boolean '## Check is selected node is a root node. With Node IsRootNode = (.FullPath = .Text) End With End Function Private Sub ScrollView(ByVal Dir As eCodeScrollView) ' '## Scrolls the treview using code ' Dim lHwnd As Long Dim lPos As Long Dim lBar1 As Long Dim lBar2 As Long Dim lDir As Long lHwnd = oTree.hWnd Select Case Dir Case [Home]: SendMessageAny lHwnd, WM_VSCROLL, SB_TOP, vbNull Case [Page Up]: SendMessageAny lHwnd, WM_VSCROLL, SB_PAGEUP, vbNull Case [Up]: SendMessageAny lHwnd, WM_VSCROLL, SB_LINEUP, vbNull Case [Down]: SendMessageAny lHwnd, WM_VSCROLL, SB_LINEDOWN, vbNull Case [Page Down]: SendMessageAny lHwnd, WM_VSCROLL, SB_PAGEDOWN, vbNull Case [End]: SendMessageAny lHwnd, WM_VSCROLL, SB_BOTTOM, vbNull Case [Left]: SendMessageAny lHwnd, WM_HSCROLL, SB_LEFT, vbNull Case [Page Left]: SendMessageAny lHwnd, WM_HSCROLL, SB_PAGELEFT, vbNull Case [Line Left]: SendMessageAny lHwnd, WM_HSCROLL, SB_LINELEFT, vbNull Case [Line Right]: SendMessageAny lHwnd, WM_HSCROLL, SB_LINERIGHT, vbNull Case [Page Right]: SendMessageAny lHwnd, WM_HSCROLL, SB_PAGERIGHT, vbNull Case [Right] ': SendMessageAny lHwnd, WM_HSCROLL, SB_RIGHT, vbNull ' '## For some reason, the treeview doesn't respond to the above commented ' out message. Therefore a work-around is required. ' '## To stop flickering, the control is hidden temporarily. oTree.Visible = False ' ## Loop until we've scrolled to the far right side Do lPos = GetScrollPos(lHwnd, 0&) SendMessageAny lHwnd, WM_HSCROLL, SB_PAGERIGHT, vbNull Loop Until (lPos = GetScrollPos(lHwnd, 0&)) '## Now show the control oTree.Visible = True End Select End Sub !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Mit dem Modul XTimers.bas genause wie mit Form1 verfahren (Notepad und so weiter) und als XTimers.bas abspeichern Attribute VB_Name = "XTimerSupport" Option Explicit '================================================ ' WARNING! DO NOT press the End button while ' debugging this project! While in Break ' mode, do NOT make edits that reset the ' project! ' ' This module is dangerous because it uses the ' SetTimer API and the AddressOf operator to ' set up a code-only timer. Once such a ' timer is set up, the system will continue ' to call the TimerProc function EVEN AFTER ' YOU RETURN TO DESIGN TIME. ' ' Since TimerProc isn't available at design ' time, the system will cause a PROGRAM ' FAULT in Visual Basic. ' ' When debugging this module, you need to make ' sure that all system timers have been ' stopped (using KillTimer) before returning ' to design time. You can do this by calling ' SCRUB from the Immediate window. ' ' Call-back timers are inherently dangerous. ' It's much safer to use Timer controls for ' most of your development process, and only ' switch to call-back timers at the very ' end. '================================================== ' Amount to increase size of the array maxti when more ' active timers are needed. (See 'MoreRoom:' below.) Const MAXTIMERINCREMEMT = 5 Private Type XTIMERINFO ' Hungarian xti xt As XTimer id As Long blnReentered As Boolean End Type Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerProc As Long) As Long Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long ' maxti is an array of active XTimer objects. The reason ' ----- for using an array of user-defined types ' instead of a Collection object is to get early ' binding when we raise the XTimer object's Tick event. Private maxti() As XTIMERINFO ' ' mintMaxTimers tells us how large the array maxti is at ' ------------- any given time. Private mintMaxTimers As Integer ' BeginTimer function is called by an XTimer object when ' ------------------- the XTimer's Interval property is ' set to a new non-zero value. ' ' The function makes the API calls required to set up a ' timer. If a timer is successfully created, the ' function puts a reference to the XTimer object into ' the array maxti. This reference will be used to call ' the method that raises the XTimer's Tick event. ' Public Function BeginTimer(ByVal xt As XTimer, ByVal Interval As Long) Dim lngTimerID As Long Dim intTimerNumber As Integer lngTimerID = SetTimer(0, 0, Interval, AddressOf TimerProc) ' Success is a non-zero return from SetTimer. If we can't ' get a timer, raise an error. If lngTimerID = 0 Then Err.Raise vbObjectError + 31013, , "No timers available" ' The following loop locates the first available slot ' in the array maxti. If the upper bound is exceeded, ' an error occurs and the array is made larger. (If ' you compile this DLL to Native Code, DO NOT turn off ' Bounds Checking!) For intTimerNumber = 1 To mintMaxTimers If maxti(intTimerNumber).id = 0 Then Exit For Next ' ' If no empty space was found, increase the ' size of the array. If intTimerNumber > mintMaxTimers Then mintMaxTimers = mintMaxTimers + MAXTIMERINCREMEMT ReDim Preserve maxti(1 To mintMaxTimers) End If ' ' Save a reference to use when raising the ' XTimer object's Tick event. Set maxti(intTimerNumber).xt = xt ' ' Save the timer id returned by the SetTimer API, and ' return the value to the XTimer object. maxti(intTimerNumber).id = lngTimerID maxti(intTimerNumber).blnReentered = False BeginTimer = lngTimerID End Function ' TimerProc is the timer procedure which the system will ' --------- call whenever one of your timers goes off. ' ' IMPORTANT -- Because this procedure must be in a ' standard module, all of your timer objects must share ' it. This means the procedure must identify which timer ' has gone off. This is done by searching the array ' maxti for the ID of the timer (idEvent). ' ' If this Sub declaration is wrong, PROGRAM FAULTS will ' occur! This is one of the dangers of using APIs ' that require call-back functions. ' Public Sub TimerProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal lngSysTime As Long) Dim intCt As Integer For intCt = 1 To mintMaxTimers If maxti(intCt).id = idEvent Then ' Don't raise the event if an earlier ' instance of this event is still ' being processed. If maxti(intCt).blnReentered Then Exit Sub ' The blnReentered flag blocks further ' instances of this event until the ' current instance finishes. maxti(intCt).blnReentered = True On Error Resume Next ' Raise the Tick event for the appropriate ' XTimer object. maxti(intCt).xt.RaiseTick If Err.Number <> 0 Then ' If an error occurs, the XTimer has ' somehow managed to terminate without ' first letting go of its timer. Clean ' up the orphaned timer, to prevent GP ' faults later. KillTimer 0, idEvent maxti(intCt).id = 0 ' ' Release the reference to the ' XTimer object. Set maxti(intCt).xt = Nothing End If ' ' Allow this event to enter TimerProc ' again. maxti(intCt).blnReentered = False Exit Sub End If Next ' The following line is a fail-safe, in case an ' XTimer somehow got freed without the Windows ' system timer getting killed. ' ' Execution can also reach this point because of ' a known bug with NT 3.51, whereby you may ' receive one extra timer event AFTER you have ' executed the KillTimer API. KillTimer 0, idEvent End Sub ' EndTimer procedure is called by the XTimer whenever ' ------------------ the Enabled property is set to ' False, and whenever a new timer interval is required. ' There is no way to reset a system timer, so the only ' way to change the interval is to kill the existing ' timer and then call BeginTimer to start a new one. ' Public Sub EndTimer(ByVal xt As XTimer) Dim lngTimerID As Long Dim intCt As Integer ' Ask the XTimer for its TimerID, so we can search the ' array for the correct XTIMERINFO. (You could ' search for the XTimer reference itself, using the ' Is operator to compare xt with maxti(intCt).xt, but ' that wouldn't be as fast.) lngTimerID = xt.TimerID ' ' If the timer ID is zero, EndTimer has been ' called in error. If lngTimerID = 0 Then Exit Sub ' For intCt = 1 To mintMaxTimers If maxti(intCt).id = lngTimerID Then ' Kill the system timer. KillTimer 0, lngTimerID ' ' Release the reference to the XTimer ' object. Set maxti(intCt).xt = Nothing ' ' Clean up the ID, to free the slot for ' a new active timer. maxti(intCt).id = 0 Exit Sub End If Next End Sub ' Scrub procedure is a safety valve for debugging purposes ' --------------- only: If you have to End this project ' while there are XTimer objects active, call Scrub from ' the Immediate pane. This will call KillTimer for all ' of the system timers, so that the development ' environment can safely return to design mode. ' Public Sub Scrub() Dim intCt As Integer ' Kill remaining active timers. For intCt = 1 To mintMaxTimers If maxti(intCt).id <> 0 Then KillTimer 0, maxti(intCt).id Next End Sub !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Und jetzt die Klasse, diese als XTimers.cls abspeichern: VERSION 1.0 CLASS BEGIN MultiUse = -1 'True Persistable = 0 'NotPersistable DataBindingBehavior = 0 'vbNone DataSourceBehavior = 0 'vbNone MTSTransactionMode = 0 'NotAnMTSObject END Attribute VB_Name = "XTimer" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit '=============================================== ' WARNING! DO NOT press the End button while ' debugging this project! See explanation ' at the top of the XTimerSupport module ' (XTimerS.bas). '=============================================== ' Private storage for XTimer properties: Private mlngTimerID As Long Private mlngInterval As Long Private mblnEnabled As Boolean ' The XTimer's only event is Tick. XTimer's Tick event ' doesn't have any arguments (eliminating arguments speeds ' up the event slightly), but there's no reason why you ' couldn't supply arguments if you wanted to. Event Tick() ' TimerID property is required by the EndTimer procedure, ' ---------------- in order to quickly locate the timer ' in the support module's array of active timers. ' ' There's no reason for the client to use this property, ' so it's declared Friend instead of Public. ' Friend Property Get TimerID() As Long TimerID = mlngTimerID End Property ' Enabled property turns the timer on and off. This is ' ---------------- done by killing the system timer, ' because there's no way to suspend a system timer. ' If they exist, they're running. ' Public Property Get Enabled() As Boolean Enabled = mblnEnabled End Property ' Public Property Let Enabled(ByVal NewValue As Boolean) ' If there's no change to the state of ' the property, then exit. This ' prevents starting a second system ' timer when one is already running, ' etcetera. If NewValue = mblnEnabled Then Exit Property ' ' Save the new property setting. mblnEnabled = NewValue ' ' If the Interval is zero, the timer ' is already stopped. Don't start it. If mlngInterval = 0 Then Exit Property ' ' Turn timer on or off. If mblnEnabled Then Debug.Assert mlngTimerID = 0 mlngTimerID = BeginTimer(Me, mlngInterval) Else ' The following is necessary, because ' an XTimer can shut off its system ' timer two ways: Enabled = False, ' or Interval = 0. If mlngTimerID <> 0 Then Call EndTimer(Me) mlngTimerID = 0 End If End If End Property ' Interval property must do more than just set the ' ----------------- timer interval. If the XTimer ' is enabled, and the Interval is changed from zero ' to a non-zero value, then a system timer must be ' started. Likewise, if the Interval is changed ' to zero, the system timer must be stopped. ' ' The Property Let procedure also ends one system timer ' and starts another whenever the interval changes. ' This is because there's no way to change the ' interval of a system timer. ' Public Property Get Interval() As Long Interval = mlngInterval End Property ' Public Property Let Interval(ByVal NewInterval As Long) ' If the new value for Interval is the same as the old, ' there's no reason to do anything. If NewInterval = mlngInterval Then Exit Property ' ' Save the new value. mlngInterval = NewInterval ' ' If the XTimer is active, mlngTimerID is non-zero. ' in this case, the old system timer must be ' ended before a new one is started. If mlngTimerID <> 0 Then Call EndTimer(Me) mlngTimerID = 0 End If ' ' If the new interval is zero, then the XTimer ' becomes inactive, regardless of the current ' value of Enabled. If the new interval is ' not zero, AND the Enabled property is True, ' then a new system timer is started, and its ' ID is stored in mlngTimerID. If (NewInterval <> 0) And mblnEnabled Then mlngTimerID = BeginTimer(Me, NewInterval) End If End Property ' RaiseTick method is called by the support module when ' ---------------- the system timer event occurs for ' this XTimer object's system timer. ' ' Implementation detail: You might expect to declare ' this method Friend instead of Public, as there's ' no need for the client to call RaiseTick. However, ' it's critical that RaiseTick be declared Public, ' because the XTimer might be released while the ' Tick event is still being handled. An object will ' not terminate while one of its Public methods is ' on the stack, but it CAN terminate while one of its ' Friend methods is on the stack. If the object ' terminates before the Friend method returns (which ' could happen if the client executes a lot of code ' in the XTimer's Tick event), a GPF will result. ' (Note that this is a highly unusual scenario that ' depends on an external event; it does not occur in ' ordinary use of Friend functions.) ' Public Sub RaiseTick() RaiseEvent Tick End Sub Private Sub Class_Terminate() ' When the client releases its last reference to ' an XTimer object, it goes away -- but only ' if the XTimer's Enabled property is False, ' or its Interval property is True! ' ' This is because while the XTimer's system ' timer is running, the XTimerSupport module ' has to have a reference to the XTimer in ' order to raise its Tick event. Thus, ' failure of the client to disable XTimer ' objects before releasing them will LEAK ' system timers! ' ' These leaked system timers will not be ' recovered until the XTimers component shuts ' down -- that is, when the client using ' the DLL shuts down. The DLL will NOT ' unload when all XTimer objects are released, ' because references to public objects (in ' this case, those held by XTimerSupport) ' will prevent a DLL from unloading. ' ' So why bother to clean up the system timer ' in the Terminate event? Because when the ' DLL is getting shut down, all references ' to the XTimer object will be cleaned up ' -- and the XTimer will get its Terminate ' event. The system timer should be ' destroyed at this point. On Error Resume Next If mlngTimerID <> 0 Then KillTimer 0, mlngTimerID ' ' The following is what XTimer should do if ' it could somehow be released prior to ' DLL shutdown. 'If mlngTimerID <> 0 Then Call EndTimer(Me) End Sub Jetzt ein neues VB Project anlegen und die 3 Dokumente einladen... Das wars auch schon wieder, wenn Du nicht klar kommst, kurze mail an mich, ich schick dir den sourcecode zu! Gruß, MAC

Wichtige Frage,für Profis	178	Japi	21.11.02 15:46
Re: Wichtige Frage,für Profis	1.495	Mac	21.11.02 20:33

Sie sind nicht angemeldet! Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden. Einloggen  |  Neu registrieren

Funktionen:  Zum Thema  |  Gesamtübersicht

Suchen