PC Plus SuperCD 45/SuperCD45.iso/talleres/vbasic/BNodeList.cls

Visual Basic class definition | 2000-01-30 | 6.7 KB | 213 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "BNodeList"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"No"
Attribute VB_Ext_KEY = "Member0" ,"Node"
Option Explicit
Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescriptor As Long
        bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200

'local variable to hold collection
Private mCol As Collection
Public Function Changed(prev As BNode) As BNodeList
Dim n As BNode, p As BNodeList, r As New BNodeList

For Each n In mCol
    If n.attributes And vbArchive Then
        Call r.Add(n.fileName, n.attributes, Nothing, n.fileName)
        Set r(n.fileName).prevBNode = prev
    End If

    If n.attributes And vbDirectory Then
        Set p = n.nextBNode.Changed(n)
        If p.Count > 0 Then
            Call r.Add(n.fileName, n.attributes, p, n.fileName)
            Set r(n.fileName).prevBNode = prev
        End If
    End If
Next

Set Changed = r

End Function
Public Function ResetArchiveBit(oldpath As String) As Long
Dim n As BNode, total As Long, ofn As String, p As BNodeList, result As Long

total = 0
For Each n In mCol
    ofn = oldpath & "\" & n.fileName
    If Not n.nextBNode Is Nothing Then
        Set p = n.nextBNode
        total = total + p.ResetArchiveBit(ofn)
    Else
        If SetFileAttributes(ofn, n.attributes - vbArchive) = 0 Then
            result = Err.LastDllError
            If MsgBox(ApiErrorText(result), vbOKCancel) = vbCancel Then
                End
            End If
        Else
            total = total + 1
        End If
    End If

Next
ResetArchiveBit = total

End Function
Public Sub WriteCatalogue(filenum As Integer, dirLevel As Integer)
Dim n As BNode, p As BNodeList, dirFlag As Boolean, pfn As String

For Each n In mCol
    dirFlag = Not n.nextBNode Is Nothing
    If n.prevBNode Is Nothing Then
        pfn = ""
    Else
        pfn = n.prevBNode.fileName
    End If
    If dirFlag Then
        Write #filenum, dirLevel, n.attributes, n.fileName, pfn, dirFlag
        Set p = n.nextBNode
        Call p.WriteCatalogue(filenum, dirLevel + 1)
    Else
        Write #filenum, dirLevel, n.attributes, n.fileName, pfn, dirFlag
    End If
Next

End Sub
Private Function ApiErrorText(ByVal errcode As Long) As String
Dim s As String, i As Long, f As Long

s = String(256, 0)

f = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS
i = FormatMessage(f, 0, errcode, 0, s, Len(s), ByVal 0)
If i > 0 Then ApiErrorText = Left$(s, i)

End Function
Public Sub CopyFiles(newpath As String, oldpath As String)
Dim n As BNode, p As BNodeList
Dim ofn As String, nfn As String, result As Long
Dim sa As SECURITY_ATTRIBUTES

' this isn't used - just set to zero
sa.bInheritHandle = 0
sa.lpSecurityDescriptor = 0
sa.nLength = 0

If CreateDirectory(newpath, sa) = 0 Then
    result = Err.LastDllError
    If MsgBox(ApiErrorText(result), vbOKCancel) = vbCancel Then
        End
    End If
End If

For Each n In mCol
    ofn = oldpath & "\" & n.fileName
    nfn = newpath & "\" & n.fileName
    If Not n.nextBNode Is Nothing Then
        Set p = n.nextBNode
        Call p.CopyFiles(nfn, ofn)
    Else
        If CopyFile(ofn, nfn, 1) = 0 Then
            result = Err.LastDllError
            If MsgBox(ApiErrorText(result), vbOKCancel) = vbCancel Then
                End
            End If
        End If
    End If
Next

End Sub
Public Function Add(fileName As String, attributes As Integer, nl As BNodeList, Optional sKey As String) As BNode
Dim objNewMember As New BNode

'set the properties passed into the method
objNewMember.fileName = fileName
Set objNewMember.nextBNode = nl
objNewMember.attributes = attributes
If Len(sKey) = 0 Then
    mCol.Add objNewMember
Else
    mCol.Add objNewMember, sKey
End If

'return the object created
Set Add = objNewMember
Set objNewMember = Nothing

End Function
Public Property Get Item(vntIndexKey As Variant) As BNode
Attribute Item.VB_UserMemId = 0
    'used when referencing an element in the collection
    'vntIndexKey contains either the Index or Key to the collection,
    'this is why it is declared as a Variant
    'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property
Public Function Display(indent As String) As String
Dim n As BNode, s As String

For Each n In mCol
    s = s & indent & n.fileName & vbCrLf
    If n.attributes And vbDirectory Then
        s = s & n.nextBNode.Display(" " & indent)
    End If
Next

Display = s

End Function
Public Property Get Count() As Long
    'used when retrieving the number of elements in the
    'collection. Syntax: Debug.Print x.Count
    Count = mCol.Count
End Property
Public Sub Remove(vntIndexKey As Variant)
    'used when removing an element from the collection
    'vntIndexKey contains either the Index or Key, which is why
    'it is declared as a Variant
    'Syntax: x.Remove(xyz)


    mCol.Remove vntIndexKey
End Sub
Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    'this property allows you to enumerate
    'this collection with the For...Each syntax
    Set NewEnum = mCol.[_NewEnum]
End Property
Private Sub Class_Initialize()
    'creates the collection when this class is created
    Set mCol = New Collection
End Sub
Private Sub Class_Terminate()
    'destroys collection when this class is terminated
    Set mCol = Nothing
End Sub