Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: polosa en Octubre 14, 2010, 01:30:42 am
-
Hi All
My English is not good.
I would like to know how to reach this site's functionality, using vb
(http://www.codeproject.com/KB/list/LVCustomReordering/ListViewCustomReorder.gif)
http://www.codeproject.com/KB/list/LVCustomReordering.aspx (http://www.codeproject.com/KB/list/LVCustomReordering.aspx)
ListViewCustomReorderSrc Examples (http://FileDeck.net/zh-tw/files/QL5SBIV4/ListViewCustomReorderSrc.zip)
-
Example in VB6...!¡.
http://vbasic.astalaweb.com/drag%20&%20drop/1_drag%20&%20drop.asp
Dulce Infierno Lunar!¡.
-
Hello, I made myself clear, please forgive me
I want to reach LISTVIEW in the function of the red lines, is not to use the function to complete custom DRAW
-
Hi, welcome to the Forum, this example is with the listview of Microsoft Common Controls version 6, for the version 5 is more complicated.
ListViewDragWithLine.zip (http://FileDeck.net/en-us/files/12KHG4P9/ListViewDragWithLine.zip)
Option Explicit
'----------------------------------------
'Autor: Leandro Ascierto
'Web: www.leandroascierto.com.ar
'Date: 14/10/2010
'----------------------------------------
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpPoint As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As Any, ByVal nCount As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function InvalidateRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As Any, ByVal bErase As Long) As Long
Private Declare Function LoadCursor Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Const IDC_HAND = 32649&
Dim m_hCursor As Long
Dim m_IndexDrag As Long
Private Sub Form_Load()
Dim LI As ListItem
Dim i As Long
ListView1.View = lvwReport
ListView1.FullRowSelect = True
For i = 0 To 3
ListView1.ColumnHeaders.Add , , "Columna" & i
Next
For i = 0 To 100
Set LI = ListView1.ListItems.Add(, , "Item" & i)
LI.SubItems(1) = "SubItem 1"
LI.SubItems(2) = "SubItem 2"
LI.SubItems(3) = Now
Next
End Sub
Private Sub ListView1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Call DragItem(ListView1, X, Y)
End If
End Sub
Private Sub ListView1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
Call EndDragItem(ListView1)
End If
End Sub
Public Sub EndDragItem(ObjListView As ListView)
Dim LI As ListItem
Dim i As Long
If m_IndexDrag > 0 Then
With ObjListView
Set LI = .ListItems.Add(m_IndexDrag, , .SelectedItem.Text)
For i = 1 To ListView1.ColumnHeaders.Count - 1
LI.SubItems(i) = .SelectedItem.SubItems(i)
Next
.ListItems.Remove .SelectedItem.Index
LI.Selected = True
m_IndexDrag = 0
End With
End If
If m_hCursor Then DestroyCursor m_hCursor: m_hCursor = 0
End Sub
Public Sub DragItem(ObjListView As ListView, ByVal X As Single, ByVal Y As Single)
Dim lTop As Long
Dim hdc As Long
Dim PT As POINTAPI
Dim ColH As ColumnHeader
Dim MaxColumnWidth As Long
Dim TheItemDrag As ListItem
With ObjListView
If .ListItems.Count = 0 Then Exit Sub
If m_hCursor = 0 Then m_hCursor = LoadCursor(0&, IDC_HAND)
SetCursor m_hCursor
InvalidateRect .hwnd, ByVal 0&, False
Set TheItemDrag = .HitTest(X, Y)
If Not TheItemDrag Is Nothing Then
Set ColH = .ColumnHeaders(.ColumnHeaders.Count)
MaxColumnWidth = (ColH.Left + ColH.Width) / Screen.TwipsPerPixelX
If Y - TheItemDrag.Top > TheItemDrag.Height / 2 Then
lTop = (TheItemDrag.Top + TheItemDrag.Height) / Screen.TwipsPerPixelY
m_IndexDrag = TheItemDrag.Index + IIf(.SelectedItem.Index < TheItemDrag.Index, 1, 0)
Else
lTop = TheItemDrag.Top / Screen.TwipsPerPixelY
m_IndexDrag = TheItemDrag.Index
End If
DoEvents
hdc = GetDC(.hwnd)
DrawLine hdc, 2, lTop, MaxColumnWidth - 1, lTop, vbRed, 1
ReleaseDC 0&, hdc
End If
End With
End Sub
Public Sub DrawLine(ByVal hdc As Long, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long, _
Optional ByVal Color As Long = -1, _
Optional ByVal BorderWidth As Long = 1)
Dim hPen As Long
Dim hBrush As Long
Dim TransColor As Long
Dim OldPen As Long
Dim OldBrush As Long
Dim PT(2) As POINTAPI
If Color <> -1 Then
Call OleTranslateColor(Color, 0&, TransColor)
hPen = CreatePen(0, BorderWidth, TransColor)
OldPen = SelectObject(hdc, hPen)
hBrush = CreateSolidBrush(Color)
OldBrush = SelectObject(hdc, hBrush)
End If
If X1 >= 0 Then
MoveToEx hdc, X1, Y1, 0
End If
LineTo hdc, X2, Y2
PT(0).X = X1: PT(0).Y = Y1 - 3
PT(1).X = 5: PT(1).Y = Y1
PT(2).X = X1: PT(2).Y = Y1 + 3
Polygon hdc, PT(0), 3
PT(0).X = X2: PT(0).Y = Y2 - 3
PT(1).X = X2 - 5: PT(1).Y = Y2
PT(2).X = X2: PT(2).Y = Y2 + 3
Polygon hdc, PT(0), 3
If Color <> -1 Then
DeleteObject SelectObject(hdc, OldPen)
DeleteObject SelectObject(hdc, OldBrush)
End If
End Sub
-
HI
After the test is ok
But I want to use the API methods do not know if I used the following method, but an error.
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMPOSITION = (LVM_FIRST + 16)
Private Function GetPositionY(ByVal iIndex As Long) As Long
Dim tP As POINTAPI
SendMessageW ucListView.hwnd, LVM_GETITEMPOSITION, iIndex, tP
GetPositionY= tP.Y
End Function
lTop = GetPositionY(ucListView.GetSelectedItem)
I used the following components at the control
http://www.leandroascierto.com.ar/categoria/Proyectos/articulo/Explorador%20Remoto.php (http://www.leandroascierto.com.ar/categoria/Proyectos/articulo/Explorador%20Remoto.php)
How do I make. I'm sorry you had trouble.
-
Leandro..! Que Groso..!
-
Tambien funciona perfectamente para la version 5... aunque claro, hay que implementar el FullRowSelect a mano ;D
-
Tambien funciona perfectamente para la version 5... aunque claro, hay que implementar el FullRowSelect a mano ;D
mira vos, ni me habia fijado que la version 5 tenia las propiedades Item .Height, .HitTest, .Top, asi que claro solo basta con utilar sendmessage par habilitar el FullRowSelect
@polosa use LVM_GETITEMRECT
Option Explicit
Private Const LVM_FIRST = &H1000
Private Const LVM_GETITEMRECT As Long = (LVM_FIRST + 14)
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Function GetItemTop(ByVal iIndex As Long) As Long
Dim Rec As RECT
SendMessage ucListView.hwnd, LVM_GETITEMRECT, iIndex, Rec
GetItemTop = Rec.Top
End Function
Private Function GetItemHeight(ByVal iIndex As Long) As Long
Dim Rec As RECT
SendMessage ucListView.hwnd, LVM_GETITEMRECT, iIndex, Rec
GetItemHeight = Rec.Bottom - Rec.Top
End Function
-
Tested. Has been a success. Thank you.
In addition, I have slightly modified the code. And add a special effect.
Let the line looks perfect.
(http://addsnaps.com/thumb/large/4116)
Public Sub DrawLine(ByVal hdc As Long, _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long, _
Optional ByVal Color As Long = -1, _
Optional ByVal BorderWidth As Long = 1)
Dim hPen As Long
Dim hBrush As Long
Dim TransColor As Long
Dim OldPen As Long
Dim OldBrush As Long
Dim pt(2) As POINTAPI
If Color <> -1 Then
Call OleTranslateColor(Color, 0&, TransColor)
hPen = CreatePen(0, BorderWidth, TransColor)
OldPen = SelectObject(hdc, hPen)
hBrush = CreateSolidBrush(Color)
OldBrush = SelectObject(hdc, hBrush)
End If
If X1 >= 0 Then MoveToEx hdc, X1, Y1, 0
LineTo hdc, X2, Y2
pt(0).X = X1: pt(0).Y = Y1 - 3
pt(1).X = X1 + 5: pt(1).Y = Y1
pt(2).X = X1: pt(2).Y = Y1 + 3
Polygon hdc, pt(0), 3
pt(0).X = X2: pt(0).Y = Y2 - 3
pt(1).X = X2 - 5: pt(1).Y = Y2
pt(2).X = X2: pt(2).Y = Y2 + 3
Polygon hdc, pt(0), 3
If Color <> -1 Then
DeleteObject SelectObject(hdc, OldPen)
DeleteObject SelectObject(hdc, OldBrush)
End If
End Sub
Private Function RenderGradient(ByVal hdc As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal Width As Long, _
ByVal Height As Long)
Dim A As Long
Dim Perc As Single
Dim vRed As Long
Dim vGreen As Long
Dim vBlue As Long
For A = 0 To Height
Perc = 1 - (A / Height)
vRed = (61 * Perc) + (37 * (1 - Perc))
vGreen = (132 * Perc) + (80 * (1 - Perc))
vBlue = (246 * Perc) + (148 * (1 - Perc))
DrawLine hdc, X, Y + A, Width, Y + A, RGB(vRed, vGreen, vBlue)
Next
End Function
'DrawLine hdc, 2, lTop, MaxColumnWidth - 1, lTop, vbRed, 1
RenderGradient hdc, 2, lTop, MaxColumnWidth - 1, 1