Flytta filer FSO


I detta tips demonstreras hur vi kan låta användarna väja en huvudmapp vars undermappars innehåll ska flytta till nya datumstämplade undermappar enligt följande struktur:

Innan nedanstående procedur exekveras:

 

Efter det att proceduren är körd:

 

I exemplet används John Walkenbachs ansats för att visa dialogrutan för val av huvudmapp men personligen föredrar jag den lösning som VBNet använder sig av och som finns att tillgå i sektionen "Implementing the Browse For Folders Dialog". (Det är inte tillåtet att visa denna lösning på annan site varför hänvisning endast sker.)

Att flytta filer kan ske på några sätt men jag föredrar att använda mig av FSO-ansatsen och då förfarandet är av engångsföreteelse används s k late binding i exemplet.

I exemplet är det PDF-filer som flyttas men kan enkelt ändras till t ex Excel- eller Word-filer eller allihopa.
 

Om ett felmeddelande erhålls vid kopiering till VBA-modul så läs mer här»
 

 

(© 2002 - 2004 All rights Colo - Used by permission)

Option Explicit

Option Private Module

 

Public Type BROWSEINFO

   hOwner As Long

   pidlRoot As Long

   pszDisplayName As String

   lpszTitle As String

   ulFlags As Long

   lpfn As Long

   lParam As Long

   iImage As Long

End Type

 

Declare Function SHGetPathFromIDList Lib "shell32.dll" _

      Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) _

      As Long

 

Declare Function SHBrowseForFolder Lib "shell32.dll" _

      Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

 

Sub Flytta_Filer()

   '© 2004 Alla rättigheter XL-Dennis

   Dim stDate As String, stFolderDate As String, stFile As String

   Dim lnAnswer As Long, stPath As String

 

   'Här används s k late binding.

   Dim oFSO As Object

   Dim oMainFolder As Object

   Dim oSubFolders As Object

   Dim oSubFolder As Object

 

   On Error GoTo Error_Handling

 

   'Anrop av funktionen för val av huvudmapp.

   stPath = GetDirectory

 

   'Kontroll om användaren har avbrutit processen.

   If stPath = "" Then GoTo Exithere

 

   'Skapar datumsträngen ååååmmdd.

   stDate = Replace(Date, "-", "")

 

   'Möjlighet att ändra sig innan exekvering sker.

   lnAnswer = MsgBox("Du har valt att flytta filer från huvudmappen " & stPath & vbCrLf _

         & "till undermappar med namnet " & stPath & "\Undermapp\" & stDate & "." & vbCrLf _

         & "Vill du fortsätta?", vbInformation + vbYesNo)

 

   'Om användaren väljer att avbryta.

   If lnAnswer = 7 Then GoTo Exithere

 

   Set oFSO = CreateObject("Scripting.FileSystemObject")

   Set oMainFolder = oFSO.GetFolder(stPath)

   Set oSubFolders = oMainFolder.SubFolders

 

   'Loopar igenom varje undermapp till den valda huvudmappen.

   'Kontrollerar om datummappen finns eller ej. Om inte så skapas den.

   'Flyttar samtliga filer från undermapp till datummappen.

   For Each oSubFolder In oSubFolders

      If oFSO.FolderExists(oSubFolder & "\" & stDate) = False Then

         oFSO.CreateFolder (oSubFolder & "\" & stDate)

      End If

      stFile = oSubFolder.Name & "\*.PDF"

      oFSO.MoveFile stFile, oSubFolder & "\" & stDate

   Next oSubFolder

 

   MsgBox "Samtliga filer i undermapparna till " & stPath & _

         " har överförts till undermapparna " & stDate & ".", vbInformation

 

   'Tömmer arbetsminnet och avslutar proceduren.

Exithere:

   Set oMainFolder = Nothing

   Set oSubFolder = Nothing

   Set oSubFolders = Nothing

   Set oFSO = Nothing

   Exit Sub

 

Error_Handling:

   If Err.Number = 53 Then

      MsgBox "Det finns inga filer att flytta!", vbCritical

   Else

      MsgBox "Fel: " & Err.Number & vbCrLf _

            & "Beskrivning: " & Err.Description & vbCrLf _

            & "har inträffat", vbCritical

   End If

   Resume Exithere

End Sub

 

Function GetDirectory() As String

   '© 2002-2004 Alla rättigheter John Walkenbach

   'Se http://j-walk.com/ss/excel/tips/tip29.htm för detaljer.

   Dim bInfo As BROWSEINFO

   Dim r As Long, x As Long, pos As Integer

   Dim stPath As String

 

   With bInfo

      .pidlRoot = 0&

      .lpszTitle = "Välj en huvudmapp."

      .ulFlags = &H1

   End With

 

   x = SHBrowseForFolder(bInfo)

 

   stPath = Space$(512)

   r = SHGetPathFromIDList(ByVal x, ByVal stPath)

   If r Then

      pos = InStr(stPath, Chr$(0))

      GetDirectory = Left(stPath, pos - 1)

   Else

      GetDirectory = ""

   End If

End Function