Sưu tập tất cả các Class (2 người xem)

levanduyet · 22/2/07

Chào các bạn,
Trước đây khi Post bài các Class Module chúng ta thường post vào những topic khác nhau. Nay tôi đề nghị các bạn post trong topic này. Như vậy sẽ dễ dàng cho việc tìm kiếm các Class.
Xin cám ơn sự hợp tác của các bạn.

Lê Văn Duyệt

levanduyet · 22/2/07

Class Hierarchical Listbox

Đây là một class module được viết bởi Andy Pope. Với Class này nó sẽ giúp chúng ta chuyển sử dụng Listbox tương tự như một TreeView.
Sau đây là đoạn code của Class module trên

Mã:

'--------------------------------------------------
' ajpHList Class Object v1.0
' Written by Andy Pope ©2003, all rights reserved.
' May be redistributed for free, but
' may not be sold without the author's explicit permission.
'--------------------------------------------------
'
Option Explicit

Const HLIST_NAME = "Hierarchical Listbox"
Const HLIST_VERSION = "v1.0"
Const HLIST_AUTHOR = "Andy Pope ©2003"

Private m_intNLevels As Integer
Private m_intNNodes As Integer
Private m_intNodeLevel() As Integer
Private m_intNodeStatus() As Integer
Private m_strNodeText() As String
Private m_strNodes() As String

Private m_strNode_Closed As String
Private m_strNode_Open As String
Private m_strNode_End As String
Private m_strNode_DropPad As String
Private m_strNode_Drop As String
Private m_strNode_Pad As String

Private WithEvents m_objListbox As MSForms.ListBox

Const NODEEND = 0
Const NODEOPEN = 1
Const NODECLOSED = 2

Public Event ClickedNode(ByVal NodeIndex As Integer, ByVal ListIndex As Integer)
Public Event DblClickedNode(ByVal NodeIndex As Integer, ByVal ListIndex As Integer)
Public Property Get Author() As String
    Author = HLIST_AUTHOR
End Property
Public Property Get Name() As String
    Name = HLIST_NAME
End Property

Public Property Get Node(Index As Integer) As String
    Node = m_strNodeText(Index)
End Property
Private Sub m_BuildDropNode()

    Dim intLen As Integer
    
    intLen = Len(m_strNode_Closed)
    If Len(m_strNode_Open) > intLen Then intLen = Len(m_strNode_Open)
    If Len(m_strNode_End) > intLen Then intLen = Len(m_strNode_End)
    
    m_strNode_DropPad = m_strNode_Drop & String(intLen - 1, " ")
    m_strNode_Pad = String(Len(m_strNode_DropPad) + 1, " ")
    
End Sub

Private Sub m_UpdateNodes(NodeIndex As Integer, RowIndex As Integer)
'
' Check whether to expand/collapse node
'
    If m_intNodeStatus(NodeIndex) = NODEEND Then
        ' do nothing
    ElseIf m_intNodeStatus(NodeIndex) = NODECLOSED Then
        m_OpenNode RowIndex, NodeIndex
    ElseIf m_intNodeStatus(NodeIndex) = NODEOPEN Then
        m_CloseNode RowIndex, NodeIndex
    End If
    m_objListbox.ListIndex = RowIndex
    
End Sub
Private Sub m_CloseNode(RowIndex As Integer, NodeIndex As Integer)
'
' Collapse Row item
'
    Dim intIndex As Integer
    Dim strBuf As String
    Dim intInsertIndex As Integer
    Dim intLevel As Integer
    Dim intRowItem As Integer
    Dim intLastNodeIndex As Integer
    Dim intNodeIndex As Integer
        
    m_strNodes(NodeIndex, m_intNodeLevel(NodeIndex)) = m_strNode_Drop & m_strNode_Closed
    m_intNodeStatus(NodeIndex) = NODECLOSED
    
    m_objListbox.List(RowIndex, 0) = m_MakeNode(NodeIndex)
    
    intLevel = m_intNodeLevel(NodeIndex)
    intLastNodeIndex = NodeIndex + 1
    Do While intLastNodeIndex < m_intNNodes - 1
        If m_intNodeLevel(intLastNodeIndex) <= intLevel Then
            ' collapse to this item
            Exit Do
        End If
        intLastNodeIndex = intLastNodeIndex + 1
    Loop
    
    intRowItem = RowIndex + 1
    intNodeIndex = m_objListbox.List(intRowItem, 1)
    Do While intNodeIndex < intLastNodeIndex
        If m_intNodeStatus(intNodeIndex) = NODEOPEN Then
            ' close open nodes as we collapse
            m_intNodeStatus(intNodeIndex) = NODECLOSED
            m_strNodes(intNodeIndex, m_intNodeLevel(intNodeIndex)) = m_strNode_Drop & m_strNode_Closed
        End If
        
        m_objListbox.RemoveItem intRowItem
        If intRowItem >= m_objListbox.ListCount Then Exit Do
        intNodeIndex = m_objListbox.List(intRowItem, 1)
    Loop
    
End Sub
Private Sub m_OpenNode(RowIndex As Integer, NodeIndex As Integer)
'
' Remove RowIndex Item and replace with next level down stuff
'
    Dim intLevel As Integer
    Dim intLastNodeIndex As Integer
    Dim intIndex As Integer
    Dim strBuf As String
    Dim intInsertIndex As Integer
    Dim strStatus As String
    Dim intItemIndex As Integer
    Dim blnLastIndent As Boolean
    
    If RowIndex = m_objListbox.ListCount - 1 Then
        ' last item in list
        intLastNodeIndex = m_intNNodes - 1
        blnLastIndent = True
    Else
        intLastNodeIndex = CInt(m_objListbox.List(RowIndex + 1, 1))
        blnLastIndent = False
    End If
    
    m_strNodes(NodeIndex, m_intNodeLevel(NodeIndex)) = m_strNode_Drop & m_strNode_Open
    m_intNodeStatus(NodeIndex) = NODEOPEN
    
    m_objListbox.List(RowIndex, 0) = m_MakeNode(NodeIndex)
    
    intInsertIndex = RowIndex + 1
    intLevel = m_intNodeLevel(NodeIndex) + 1
    
    For intIndex = NodeIndex + 1 To intLastNodeIndex - 1
        If m_intNodeLevel(intIndex) <= intLevel Then
            m_objListbox.AddItem m_MakeNode(intIndex), intInsertIndex
            m_objListbox.List(intInsertIndex, 1) = CStr(intIndex)
            intInsertIndex = intInsertIndex + 1
        End If
    Next
    
End Sub
Private Function m_MakeNode(NodeIndex As Integer) As String
'
' Create a node constructor list
'
    Dim intLevelIndex As Integer
    Dim strText As String
    
    For intLevelIndex = 0 To m_intNodeLevel(NodeIndex) - 1 'm_intNLevels
        strText = strText & m_strNodes(NodeIndex, intLevelIndex)
    Next
    strText = strText & m_strNodes(NodeIndex, m_intNodeLevel(NodeIndex)) & m_strNodeText(NodeIndex)
    
    m_MakeNode = strText

End Function
Public Sub AddNode(Text As String, Level As Integer)
'
'
    ReDim Preserve m_strNodeText(m_intNNodes) As String
    ReDim Preserve m_intNodeLevel(m_intNNodes) As Integer
    ReDim Preserve m_intNodeStatus(m_intNNodes) As Integer
    
    m_strNodeText(m_intNNodes) = Text
    m_intNodeLevel(m_intNNodes) = Level
    
    m_intNNodes = m_intNNodes + 1
    
    If Level > m_intNLevels Then m_intNLevels = Level   ' remember deepest level
    
End Sub
Public Sub Create()
'
' build up node constructors
'
    m_CreateNodes
    m_BuildNodeList
        
End Sub
Private Sub m_CreateNodes()
'
' Construct the node connectors
' Default starting position is Closed
'
    Dim intLevelIndex As Integer
    Dim intNodeIndex As Integer
    Dim intCurrentLevel As Integer
    Dim intStartDrop As Integer
    Dim intEndDrop As Integer
    Dim intNode As Integer
    Dim strText As String
    Dim intLevel As Integer
    
    ReDim m_strNodes(m_intNNodes, m_intNLevels) As String
    
    For intNodeIndex = 1 To m_intNNodes - 1
        For intLevel = 0 To m_intNodeLevel(intNodeIndex)
            m_strNodes(intNodeIndex, intLevel) = m_strNode_Pad
        Next
    Next
    
    For intNodeIndex = 0 To m_intNNodes - 1
    
        m_intNodeStatus(intNodeIndex) = NODEEND
        intCurrentLevel = m_intNodeLevel(intNodeIndex)
        If (intNodeIndex + 1) < m_intNNodes Then
            intStartDrop = intNodeIndex + 1
            intEndDrop = intStartDrop
            If intEndDrop < m_intNNodes Then
                Do While intEndDrop < m_intNNodes
                    If m_intNodeLevel(intEndDrop) <> intCurrentLevel Then
                        If m_intNodeLevel(intEndDrop) < intCurrentLevel Then
                            ' do not drop thru higher level node
                            intEndDrop = intStartDrop - 1
                            Exit Do
                        End If
                    ElseIf m_intNodeLevel(intEndDrop) = intCurrentLevel Then
                        ' do not drop thru higher level node
                        intEndDrop = intEndDrop - 1
                        Exit Do
                    End If
                    intEndDrop = intEndDrop + 1
                Loop
                If intEndDrop = m_intNNodes Then
                ' gone passes last node
                    If m_intNodeLevel(m_intNNodes - 1) <> intCurrentLevel Then
                        ' check last node against the level
                        intEndDrop = intStartDrop - 1
                    Else
                        intEndDrop = m_intNNodes
                    End If
                End If
            
            Else
                intEndDrop = intStartDrop - 1
            End If
            For intNode = intStartDrop To intEndDrop
                m_strNodes(intNode, intCurrentLevel) = m_strNode_DropPad
            Next
            
            If m_intNodeLevel(intNodeIndex + 1) > intCurrentLevel Then
                m_strNodes(intNodeIndex, intCurrentLevel) = m_strNode_Drop & m_strNode_Closed
                m_intNodeStatus(intNodeIndex) = NODECLOSED
            Else
                m_strNodes(intNodeIndex, intCurrentLevel) = m_strNode_Drop & m_strNode_End
                m_intNodeStatus(intNodeIndex) = NODEEND
            End If
        Else
            ' last item
            m_strNodes(intNodeIndex, intCurrentLevel) = m_strNode_Drop & m_strNode_End
            m_intNodeStatus(intNodeIndex) = NODEEND
        End If
    Next
    
End Sub

Lê Văn Duyệt

levanduyet · 22/2/07

Class Hierarchical Listbox (tiếp theo)

Mã:

Private Sub m_BuildNodeList()
'
' Fill listbox with valid nodes
'
    Dim intNodeIndex As Integer
    Dim intItemIndex As Integer
    Dim strStatus As String
    Dim strBuf As String
    
    m_objListbox.Clear
    For intNodeIndex = 0 To m_intNNodes - 1
        If m_intNodeLevel(intNodeIndex) <= 0 Then
            m_objListbox.AddItem m_MakeNode(intNodeIndex)
            intItemIndex = m_objListbox.ListCount - 1
            m_objListbox.List(intItemIndex, 1) = CStr(intNodeIndex)
        End If
    Next
End Sub

Public Property Get DisplayListCount() As Integer
' number of items currenlt showing
    DisplayListCount = m_objListbox.ListCount - 1
End Property
Public Property Let NodeClosedText(Text As String)
' user set Close Node text
    m_strNode_Closed = Text
    
    m_BuildDropNode
End Property
Public Property Get NodeClosedText() As String
    NodeClosedText = m_strNode_Closed
End Property
Public Property Get NodeOpenText() As String
    NodeOpenText = m_strNode_Open
End Property
Public Property Get NodeEndText() As String
    NodeEndText = m_strNode_End
End Property
Public Property Get NodeDropText() As String
    NodeDropText = m_strNode_Drop
End Property
Public Property Let NodeOpenText(Text As String)
' user set Open Node text
    m_strNode_Open = Text
    m_BuildDropNode
End Property
Public Property Let NodeDropText(Text As String)
' user set Drop Node text
    m_strNode_Drop = Text
    
    m_BuildDropNode
End Property
Public Property Let NodeEndText(Text As String)
' user set End Node text
    m_strNode_End = Text
    m_BuildDropNode

End Property
Public Property Get NodeCount() As Integer
' count of all items
    NodeCount = m_intNNodes - 2
End Property
Public Sub Refresh()
    m_CreateNodes
    m_BuildNodeList
End Sub

Public Property Set UseListbox(LBox As MSForms.ListBox)
    Set m_objListbox = LBox
End Property
Public Property Get Version() As String
    Version = HLIST_VERSION
End Property

Private Sub Class_Initialize()

    Dim intLen As Integer
    
    m_strNode_Closed = "..+."
    m_strNode_Open = "..-."
    m_strNode_End = "...."
    m_strNode_Drop = "!"

    m_BuildDropNode
    
End Sub

Private Sub Class_Terminate()
    
    Set m_objListbox = Nothing
    
End Sub


Private Sub m_objListbox_Click()

    Dim intIndex As Integer
    Dim intNodeIndex As Integer
    
    intIndex = m_objListbox.ListIndex
    intNodeIndex = CInt(m_objListbox.List(intIndex, 1))
    
    RaiseEvent ClickedNode(intNodeIndex, intIndex)
    
End Sub
Private Sub m_objListbox_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim intRowIndex As Integer
    Dim intNodeIndex As Integer
    
    intRowIndex = m_objListbox.ListIndex
    intNodeIndex = CInt(m_objListbox.List(intRowIndex, 1))
    
    m_UpdateNodes intNodeIndex, intRowIndex
    RaiseEvent DblClickedNode(intNodeIndex, intRowIndex)
    
End Sub
Private Sub m_objListbox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    Dim intRowIndex As Integer
    Dim intNodeIndex As Integer
    
    If KeyCode = vbKeyReturn Then
        intRowIndex = m_objListbox.ListIndex
        intNodeIndex = CInt(m_objListbox.List(intRowIndex, 1))
        m_UpdateNodes intNodeIndex, intRowIndex
    End If
    
End Sub

Để sử dụng class trên. Bạn hãy thêm vào một form, trên form thêm vào một listbox có tên ListBox1 vào bạn hãy thêm vào đoạn code này vào module của form đó như sau:

Mã:

Private Sub UserForm_Initialize()
    
    ListBox1.Move 0, 0, 200, Me.InsideHeight - 2
    
   
    Set m_objHList = New ajpHList 'Khoi tao bien
    Set m_objHList.UseListbox = ListBox1 'ListBox1 la HList
        
    
    With m_objHList
    
    '
    ' The levels begin at 0 (zero)
    ' Increase in level should be incremental
    '
        .AddNode "One", 0
        .AddNode "Two", 1
        .AddNode "Three", 1
        .AddNode "Four", 1
        .AddNode "Five", 0
        .AddNode "Six", 1
        .AddNode "Seven", 2
        .AddNode "Eight", 2
        .AddNode "Nine", 2
        .AddNode "Ten", 1
        .AddNode "Eleven", 2
        .AddNode "Twelve", 2
        .AddNode "Thirteen", 2
        .AddNode "Fourteen", 2
        .AddNode "Fifteen", 0
        .AddNode "Sixteen", 1
        .AddNode "Seventeen", 2
        .AddNode "Eighteen", 3
        .AddNode "Nineteen", 4
        .AddNode "Twenty", 0
        .AddNode "Twenty One", 1
        .AddNode "Twenty Two", 1
        .AddNode "Twenty Three", 2
        .AddNode "Twenty Four", 3
        .AddNode "Twenty Five", 0
        .Create
    End With
    
End Sub

Lê Văn Duyệt

levanduyet · 22/2/07

Update add-in thông qua Internet

Chào các bạn,
Đôi khi các bạn viết một add-in sau đó các bạn có một số thay đổi muốn cập nhật add-in của mình thông qua Internet...các bạn phải làm sao?
Bạn hãy dùng một class module sau "clsUpdate". Chú ý bạn phải tham chiếu đến thư viện "Microsoft Internet Controls".

Mã:

'-------------------------------------------------------------------------
' Class Module    : clsUpdate
' Company         : JKP Application Development Services (c)
' Author          : Jan Karel Pieterse
' Created         : 19-2-2007
' Purpose         : Class to check for program updates
'-------------------------------------------------------------------------
Option Explicit

Private Declare Function URLDownloadToFile Lib "urlmon" _
    Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, ByVal szFileName As String, _
    ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long

Private mdtLastUpdate As Date

Private msAppName As String
Private msBuild As String
Private msCheckURL As String
Private msCurrentadd-inName As String
Private msDownloadName As String
Private msTempadd-inName As String

Private Sub DownloadFile(strWebFilename As String, strSaveFileName As String)
    ' Download the file.
    URLDownloadToFile 0, strWebFilename, strSaveFileName, 0, 0
End Sub

Public Function IsThereAnUpdate() As Boolean
    Dim oIE As InternetExplorer
    Set oIE = New InternetExplorer
    With oIE
        .Navigate2 CheckURL
        Do
        Loop Until .Busy = False
        If Len(.Document.body.innerhtml) > 0 Then
            If CLng(.Document.body.innerhtml) > CLng(Build) Then
                IsThereAnUpdate = True
            End If
        End If
        .Quit
    End With
    Set oIE = Nothing
End Function

Public Property Get Build() As String
    Build = msBuild
End Property

Public Property Let Build(ByVal sBuild As String)
    msBuild = sBuild
End Property

Public Sub RemoveOldCopy()
    Currentadd-inName = ThisWorkbook.FullName
    Tempadd-inName = Currentadd-inName & "(OldVersion)"
    On Error Resume Next
    Kill Tempadd-inName
End Sub

Public Function GetUpdate() As Boolean
    On Error Resume Next
    ThisWorkbook.SaveAs Tempadd-inName
    DoEvents
    Kill Currentadd-inName
    On Error GoTo 0
    DownloadFile DownloadName, Currentadd-inName
    LastUpdate = Now
    If Err = 0 Then GetUpdate = True
End Function

Private Property Get Currentadd-inName() As String
    Currentadd-inName = msCurrentadd-inName
End Property

Private Property Let Currentadd-inName(ByVal sCurrentadd-inName As String)
    msCurrentadd-inName = sCurrentadd-inName
End Property

Private Property Get Tempadd-inName() As String
    Tempadd-inName = msTempadd-inName
End Property

Private Property Let Tempadd-inName(ByVal sTempadd-inName As String)
    msTempadd-inName = sTempadd-inName
End Property

Public Property Get DownloadName() As String
    DownloadName = msDownloadName
End Property

Public Property Let DownloadName(ByVal sDownloadName As String)
    msDownloadName = sDownloadName
End Property

Public Property Get CheckURL() As String
    CheckURL = msCheckURL
End Property

Public Property Let CheckURL(ByVal sCheckURL As String)
    msCheckURL = sCheckURL
End Property

Public Property Get LastUpdate() As Date
    Dim dtNow As Date
    dtNow = Int(Now)
    mdtLastUpdate = CDate(GetSetting(AppName, "Updates", "LastUpdate", CStr(dtNow)))
    If mdtLastUpdate = dtNow Then
        'Never checked for an update, save today!
        SaveSetting AppName, "Updates", "LastUpdate", CStr(Int(dtNow))
    End If
    LastUpdate = mdtLastUpdate
End Property

Public Property Let LastUpdate(ByVal dtLastUpdate As Date)
    mdtLastUpdate = dtLastUpdate
    SaveSetting AppName, "Updates", "LastUpdate", CStr(Int(mdtLastUpdate))
End Property

Public Property Get AppName() As String
    AppName = msAppName
End Property

Public Property Let AppName(ByVal sAppName As String)
    msAppName = sAppName
End Property

Và bạn thêm vào đoạn code sau đây trong module để thực hiện việc cập nhật

Mã:

Option Explicit

Public Sub CheckAndUpdate()
    Dim cUpdate As clsUpdate
    Set cUpdate = New clsUpdate
    With cUpdate
        'Set intial values of class
        'Current build
        .Build = "0"
        'Name of this app, probably a global variable, such as GSAPPNAME
        .AppName = "CheckForUpdate"
        'Get rid of old backup copy
        .RemoveOldCopy
        'URL which contains build # of new version
        .CheckURL = "http://www.jkp-ads.com/downloads/UpdateAnAddinBuild.htm"
        'Check once a week
        If Now - .LastUpdate >= 7 Or Int(Now) = .LastUpdate Then
            If .IsThereAnUpdate Then
                If MsgBox("We have an update, do you wish to download?", _
                            vbQuestion + vbYesNo) = vbYes Then
                    .DownloadName = "http://www.jkp-ads.com/downloads/" & _
                                     ThisWorkbook.Name
                    If .GetUpdate Then
                        MsgBox "Successfully updated the add-in, " & vbNewLine & _
                               "please restart Excel to start using the new version!", _
                                vbOKOnly + vbInformation
                    Else
                        MsgBox "Updating has failed.", vbInformation + vbOKOnly
                    End If
                End If
            End If
        End If
    End With
    Set cUpdate = Nothing
End Sub

Thật là tuyệt phải không các bạn! So cool...

Lê Văn Duyệt

Sưu tập tất cả các Class (2 người xem)

Người dùng đang xem chủ đề này

levanduyet

Hãy để gió cuốn đi.

levanduyet

Hãy để gió cuốn đi.

levanduyet

Hãy để gió cuốn đi.

levanduyet

Hãy để gió cuốn đi.

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian