Code des FileSys-Objekts

Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetVolumeInformation Lib "kernel32.dll" _
 Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
 ByVal lpVolumeNameBuffer As String, _
 ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _
 lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _
 ByVal lpFileSystemNameBuffer As String, _
 ByVal nFileSystemNameSize As Long) As Long
Private Declare Function SHFormatDrive Lib "shell32" _
 (ByVal hWnd As Long, ByVal Drive As Long, ByVal fmtID As Long, _
 ByVal Options As Long) As Long
Private Declare Function SHRestartSystemMB Lib "shell32" _
 Alias "#59" (ByVal hOwner As Long, ByVal sExtraPrompt As String, _
 ByVal uFlags As Long) As Long

Private Enum ConvertConstants
  cvfiFilesOnly = 0
  cvfiFoldersOnly = 1
  cvfiAll = 2
End Enum

Private Enum CopyFoldersConstants
  cfiCopyFiles = 0
  cfiFolderStructureOnly = 1
  cfiCreateFiles = 2
End Enum

Private Enum RelativePathErrors
  rpiErrTooManySteps = vbObjectError + 10001
  rpiErrDifferentRoot = vbObjectError + 10011
End Enum

Private Enum fdReturnConstants
  fdiRetSuccess = 0
  fdiRetError = -1
  fdiRetCancelled = -2
  fdiRetNotFormattable = -3
  fdiRetInvalidDrive = -4
End Enum

Private Enum SystemChangeModeConstants
  sciShutDown = 1
  sciRestart = 4
End Enum

Public Property Get cvfFilesOnly() As Long
  cvfFilesOnly = cvfiFilesOnly
End Property

Public Property Get cvfFoldersOnly() As Long
  cvfFoldersOnly = cvfiFoldersOnly
End Property

Public Property Get cvfAll() As Long
  cvfAll = cvfiAll
End Property

Public Property Get cfCopyFiles() As Long
  cfCopyFiles = cfiCopyFiles
End Property

Public Property Get cfFolderStructureOnly() As Long
  cfFolderStructureOnly = cfiFolderStructureOnly
End Property

Public Property Get cfCreateFiles() As Long
  cfCreateFiles = cfiCreateFiles
End Property

Public Property Get fdRetSuccess() As Long
  fdRetSuccess = fdiRetSuccess
End Property

Public Property Get fdRetError() As Long
  fdRetError = fdiRetError
End Property

Public Property Get fdRetCancelled() As Long
  fdRetCancelled = fdiRetCancelled
End Property

Public Property Get fdRetNotFormattable() As Long
  fdRetNotFormattable = fdiRetNotFormattable
End Property

Public Property Get fdRetInvalidDrive() As Long
  fdRetInvalidDrive = fdiRetInvalidDrive
End Property

Public Property Get rpErrTooManySteps() As Long
  rpErrTooManySteps = rpiErrTooManySteps
End Property

Public Property Get rpErrDifferentRoot() As Long
  rpErrDifferentRoot = rpiErrDifferentRoot
End Property

Public Property Get scShutDown()
  scShutDown = sciShutDown
End Property

Public Property Get scRestart()
  scRestart = sciRestart
End Property

Public Property Get CurDir() As String
  CurDir = VBA.CurDir$
End Property

Public Function ChDir(Path As String) As String
  On Error Resume Next
  VBA.ChDir Path
  ChDir = VBA.CurDir$
End Function

Public Function ChDrive(Drive As String) As String
  On Error Resume Next
  VBA.ChDrive Left$(Drive, 1)
  ChDrive = VBA.CurDir$
End Function

Public Function ConvertFilesFoldersCase(Path As String, _
 Optional ByVal StrConvert As Long = 2, _
 Optional ByVal IncludeSubFolders As Boolean, _
 Optional ByVal Convert As Long = 2, _
 Optional ByVal ExcludeStartFolder As Boolean) As Collection

  Dim nErrs As Collection
  
  Select Case StrConvert
    Case vbUpperCase, vbLowerCase
    Case Else
      Exit Function
  End Select
  Set nErrs = New Collection
  On Error Resume Next
  With New FileSystemObject
    If .FileExists(Path) Then
      With .GetFile(Path)
        Name Path As StrConv(Path, StrConvert)
      End With
      If Err.Number Then
        nErrs.Add Path
      End If
    ElseIf .FolderExists(Path) Then
      zConvertFilesFoldersCase nErrs, .GetFolder(Path), _
       StrConvert, IncludeSubFolders, Convert
    Else
      nErrs.Add Path
    End If
  End With
  Set ConvertFilesFoldersCase = nErrs
End Function

Private Sub zConvertFilesFoldersCase(Errs As Collection, _
 Folder As Folder, ByVal StrConvert As VbStrConv, _
 ByVal IncludeSubFolders As Boolean, _
 ByVal Convert As ConvertConstants, _
 Optional ByVal ExcludeStartFolder As Boolean)

  Dim nFile As File
  Dim nFolder As Folder
  Dim nPath As String
  
  On Error Resume Next
  With Folder
    If Not ExcludeStartFolder Then
      If Convert Then
        nPath = .Path
        Name nPath As StrConv(nPath, StrConvert)
      End If
      If Err.Number Then
        Errs.Add .Path
        Err.Clear
      End If
    End If
    For Each nFile In .Files
      With nFile
        nPath = .Path
        Name nPath As StrConv(nPath, StrConvert)
        If Err.Number Then
          Errs.Add .Path
          Err.Clear
        End If
      End With
    Next
    If IncludeSubFolders Then
      For Each nFolder In .SubFolders
        zConvertFilesFoldersCase _
         Errs, nFolder, StrConvert, True, Convert
      Next
    End If
  End With
End Sub

Public Sub CopyFolders(SourcePath As String, DestPath As String, _
 Optional ByVal CopyMode As Long, _
 Optional ByVal Overwrite As Boolean)

  Dim nFSO As FileSystemObject
  Dim nDestPath As String
  
  Set nFSO = New FileSystemObject
  If CopyMode = cfiCopyFiles Then
    With nFSO
      nDestPath = .BuildPath(DestPath, .GetBaseName(SourcePath))
      If .FolderExists(nDestPath) Imp Overwrite Then
        .CopyFolder SourcePath, nDestPath, Overwrite
      End If
    End With
  Else
    zCopyFolders nFSO.GetFolder(SourcePath), DestPath, _
     nFSO, CBool(CopyMode = cfiCreateFiles), Overwrite
  End If
End Sub

Private Sub zCopyFolders(SourceFolder As Folder, _
 DestPath As String, FSO As FileSystemObject, _
 ByVal CreateFiles As Boolean, ByVal Overwrite As Boolean)

  Dim nDestFolder As Folder
  Dim nDestPath As String
  Dim nSubFolder As Folder
  Dim nFile As File
  Dim nFileName As String
  
  With FSO
    nDestPath = .BuildPath(DestPath, SourceFolder.Name)
    If Not .FolderExists(nDestPath) Then
      Set nDestFolder = .CreateFolder(nDestPath)
    End If
    For Each nSubFolder In SourceFolder.SubFolders
      zCopyFolders nSubFolder, nDestPath, FSO, CreateFiles, _
       Overwrite
    Next
    If CreateFiles Then
      For Each nFile In SourceFolder.Files
        nFileName = .BuildPath(nDestPath, nFile.Name)
        If .FileExists(nFileName) Imp Overwrite Then
          .CreateTextFile nFileName, Overwrite
        End If
      Next
    End If
  End With
End Sub

Public Function FileSystemName(Path As String) As String
  Dim nFileSystem As String
  Dim nLDummy As Long
  Dim nIDummy As Integer
  Dim nSDummy As String
  Dim nRetVal As Long
  Dim nDrive As String
  
  nDrive = LCase$(Left$(Path, 1))
  If nDrive = "\" Then
    Exit Function
  Else
    nDrive = nDrive & ":\"
  End If
  nFileSystem = Space$(256)
  If GetVolumeInformation(nDrive, nSDummy, nIDummy, nLDummy, _
   nLDummy, nLDummy, nFileSystem, Len(nFileSystem)) <> 0 Then
    FileSystemName = Left$(nFileSystem, InStr(nFileSystem, _
     vbNullChar) - 1)
  End If
End Function

Public Function FormatDriveDlg(Drive As Variant) As Long
  Dim nDriveNumber As Long
  
  Const SHFMT_ID_DEFAULT = &HFFFF&
  Const SHFMT_OPT_FULL = 1
  
  If IsNumeric(Drive) Then
    Select Case CLng(Drive)
      Case 0 To 25
        nDriveNumber = CLng(Drive)
      Case Else
        FormatDriveDlg = fdiRetInvalidDrive
        Exit Function
    End Select
  ElseIf VarType(Drive) = vbString Then
    Select Case UCase$(Left$(Drive, 1))
      Case "A" To "Z"
      nDriveNumber = Asc(UCase$(Left$(Drive, 1))) - 65
      Case Else
        FormatDriveDlg = fdiRetInvalidDrive
        Exit Function
    End Select
  End If
  FormatDriveDlg = SHFormatDrive(GetDesktopWindow(), nDriveNumber, _
   SHFMT_ID_DEFAULT, SHFMT_OPT_FULL)
End Function

Public Function MakeRelativePath(Path As String, _
 Optional BasePath As String, _
 Optional PathSeparator As String = "\") As String

  Dim nPath As String
  Dim nPathParts As Variant
  Dim nBasePath As String
  Dim nBaseParts As Variant
  Dim i As Integer
  Dim nRelative As Boolean
  Dim nRelativePath As String
  Dim p As Integer
  
  If Left$(Path, 2) = "\\" Then
    nPath = Mid$(Path, 3)
  Else
    nPath = Path
  End If
  nPathParts = Split(nPath, PathSeparator)
  If Len(BasePath) Then
    nBasePath = BasePath
  Else
    nBasePath = CurDir
  End If
  If Right$(nBasePath, 1) = PathSeparator Then
    nBasePath = Left$(nBasePath, Len(nBasePath) - 1)
  End If
  If Left$(nBasePath, 2) = "\\" Then
    nBasePath = Mid$(nBasePath, 3)
  End If
  nBaseParts = Split(nBasePath, PathSeparator)
  If LCase$(nBaseParts(0)) <> LCase(nPathParts(0)) Then
    Err.Raise rpiErrDifferentRoot, _
     "modRelativePaths.MakeRelativePath", "rpiErrDifferentRoot"
  End If
  For i = 1 To UBound(nBaseParts)
    If nRelative Then
      nRelativePath = "..\" & nRelativePath
    Else
      If LCase$(nBaseParts(i)) <> LCase(nPathParts(i)) Then
        nRelative = True
        nRelativePath = ".."
        For p = i To UBound(nPathParts)
          nRelativePath = nRelativePath & PathSeparator _
           & nPathParts(p)
        Next 'p
      End If
    End If
  Next 'i
  If Len(nRelativePath) Then
    MakeRelativePath = nRelativePath
  Else
    MakeRelativePath = nPathParts(UBound(nPathParts))
  End If
End Function

Public Function ResolveRelativePath(RelativePath As String, _
 Optional BasePath As String, _
 Optional PathSeparator As String = "\") As String

  Dim nBasePath As String
  Dim nBaseParts As Variant
  Dim nPathParts As Variant
  Dim i As Integer
  Dim p As Integer
  Dim nPath As String
  Dim nResolvedPath As String
  Dim nServerRoot As String
  
  If Len(BasePath) Then
    nBasePath = BasePath
  Else
    nBasePath = CurDir
  End If
  If Right$(nBasePath, 1) = PathSeparator Then
    nBasePath = Left$(nBasePath, Len(nBasePath) - 1)
  End If
  If Left$(nBasePath, 2) = "\\" Then
    nBasePath = Mid$(nBasePath, 3)
    nServerRoot = "\\"
  End If
  nPathParts = Split(RelativePath, PathSeparator)
  If nPathParts(0) = ".." Then
    nBaseParts = Split(nBasePath, PathSeparator)
    For i = 0 To UBound(nPathParts)
      If nPathParts(i) = ".." Then
        p = p + 1
      Else
        If p Then
          nPath = nPath & PathSeparator & nPathParts(i)
        End If
      End If
    Next 'i
    If p > UBound(nBaseParts) Then
      Err.Raise rpiErrTooManySteps, _
       "modRelativePaths.ResolvePath", "rpiErrTooManySteps"
    Else
      For i = 0 To UBound(nBaseParts) - p
        nResolvedPath = nResolvedPath & nBaseParts(i) _
         & PathSeparator
      Next 'i
      ResolveRelativePath = nServerRoot & nResolvedPath _
       & Mid$(nPath, 2)
    End If
  Else
    ResolveRelativePath = nServerRoot & nBasePath _
     & PathSeparator & RelativePath
  End If
End Function

Public Sub SettingsChanged(Optional ByVal Mode As Long = 4, _
 Optional ExtraPrompt As String)

  Dim nMode As SystemChangeModeConstants
  
  Select Case Mode
    Case sciShutDown, sciRestart
      nMode = Mode
    Case Else
      nMode = sciRestart
  End Select
  SHRestartSystemMB GetDesktopWindow(), ExtraPrompt, nMode
End Sub

Copyright © 1999 - 2011 Harald M. Genauck, ip-pro gmbh  /  Impressum