Sub dirCopy(FromPath As String, ToPath As String)
ReDim FileName(1) As String


If Right(FromPath, 1) <> "\" Then FromPath = FromPath & "\"
If Right(ToPath, 1) <> "\" Then ToPath = ToPath & "\"


If (Dir(FromPath, vbDirectory) <> "") And (Dir(ToPath, vbDirectory) <> "") Then
Dim i As Integer
i = 0
FileName(i) = Dir(FromPath, vbDirectory)
While FileName(i) <> ""
If (GetAttr(FromPath & FileName(i)) And vbDirectory) = vbDirectory Then
If FileName(i) <> "." And FileName(i) <> ".." Then
i = i + 1
ReDim Preserve FileName(i + 1) As String
End If
Else
FileCopy FromPath & FileName(i), ToPath & FileName(i)
End If

FileName(i) = Dir
Wend

'Kopiera underkatalogerna
If i > 0 Then
For Each directory In FileName
If directory <> "" Then
'förbered den nya katalogen
MkDir ToPath & directory

'kopiera katalogen
dirCopy FromPath & directory, ToPath & directory
End If
Next
End If
End If
End Sub