Question

VB 复制文件夹函数

RT 谁帮我下一个复制文件夹的函数 具体要求如下:

指定一个目录c:\123
将其中的文件夹、文件以及子文件夹中的文件 复制到d:\123 中
(要求按照文件夹结构进行复制 d:123中不存在的文件夹要创建)

Answer 1

用CopyFolder 方法可以复制文件夹。

语法
object.CopyFolder source, destination[, overwrite]
其中，object只能是FileSystemObject对象(见后面示例).
CopyFolder 方法语法有如下几部分：
Object 必需的。始终为一个 FileSystemObject 的名字。
source 必需的。指明一个或多个被复制文件夹的字符串文件夹说明，可以包括通配符。
destination 必需的。指明 source 中被复制文件夹和子文件夹的接受端的字符串，不允许有通配符。
overwrite 选项的。Boolean 值，它表示已存在的文件夹是否被覆盖。如果为 True，文件被覆盖。如果为 False，文件不被覆盖。缺省值为 True。

说明

通配符仅可用于 source 参数的最后一个路径部件。例如你可以在下面情况使用它：

FileSystemObject.CopyFolder "c:\mydocuments\letters\*", "c:\tempfolder\"

但不能在下面情况使用它：

FileSystemObject.CopyFolder "c:\mydocuments\*\*", "c:\tempfolder\"

如果 source 包含通配符或 destination 以路径分隔符（\）为结尾，则认为 destination 是一个已存在的文件夹，在其中复制相匹配的文件夹和子文件夹。否则认为 destination 是一个要创建的文件夹的名字。不论何种情况，当复制一个文件夹时，可能发生四种事件。

如果 destination 不存在，source 文件夹和它所有的内容得到复制。这是通常的情况。

如果 destination 是一个已存在的文件，则发生一个错误。

如果 destination 是一个目录，它将尝试复制文件夹和它所有的内容。如果一个包含在 source 的文件已在 destination 中存在，当 overwrite 为 False 时发生一个错误，否则它将尝试覆盖这个文件。

如果 destination 是一个只读目录，当尝试去复制一个已存在的只读文件到此目录并且 overwrite为 False 时，则发生一个错误。
如果 source 使用的通配符不能和任何文件夹匹配，也发生一个错误。

CopyFolder 方法停止在它遇到的第一个错误上。不要尝试回卷错误发生前所做的任何改变。

示例：
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFolder "C:\Downloads\", "D:\"

FileSystemObject对象除了CopyFolder方法，还有其它很多，如BuildPath、CopyFile、CreatFolder等等，详见msdn帮助

Answer 2

shell "cmd /c xcopy c:\123 d:\123"

Answer 3

http://zhidao.baidu.com/question/127194215.html
这个地址里面的应该挺全吧。。

Answer 4

------------------------------------
'定义win文件夹操作的函数（复制和删除，其它的(移动、改名)没用到）
'删除文件夹的函数：KillPath(path)
'复制文件夹的函数：CopyPath(mpath,tPath)
'------------------------------------
Private Const FO_MOVE = &H1
Private Const FO_COPY = &H2
Private Const FO_DELETE = &H3
Private Const FO_RENAME = &H4
Private Const FOF_NOCONFIRMATION = &H10
Private Const FOF_SILENT = &H4
Private Const FOF_NOERRORUI = &H400
Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String 'only used if FOF_SIMPLEPROGRESS
End Type

'删除文件夹的函数：KillPath(path)
Public Function KillPath(ByVal sPath As String) As Boolean
On Error Resume Next
Dim udtPath As SHFILEOPSTRUCT
udtPath.hwnd = 0
udtPath.wFunc = FO_DELETE
udtPath.pFrom = sPath
udtPath.pTo = ""
udtPath.fFlags = FOF_NOCONFIRMATION Or FOF_SILENT Or FOF_NOERRORUI
KillPath = Not CBool(SHFileOperation(udtPath))
End Function

'复制文件夹的函数：CopyPath(mpath,tPath)
Public Function CopyPath(ByVal mPath As String, ByVal tPath As String) As Boolean
On Error Resume Next
Dim shfileop As SHFILEOPSTRUCT
shfileop.hwnd = 0
shfileop.wFunc = FO_COPY
shfileop.pFrom = mPath
shfileop.pTo = tPath
shfileop.fFlags = FOF_NOCONFIRMATION Or FOF_SILENT Or FOF_NOERRORUI
CopyPath = Not CBool(SHFileOperation(shfileop))
End Function
'------------------------
'------------------------
希望对你有帮助！
说明：来自互联网！

Answer 5

把下面文件 保存为form1.frm 然后运行form1.frm

VERSION 5.00
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "Form1"
ClientHeight = 7455
ClientLeft = 45
ClientTop = 435
ClientWidth = 8880
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 7455
ScaleWidth = 8880
StartUpPosition = 2 '屏幕中心
Begin VB.TextBox Text2
Height = 270
Left = 1200
TabIndex = 10
Top = 600
Width = 6255
End
Begin VB.CommandButton Command5
Caption = "浏 览"
Height = 255
Left = 7680
TabIndex = 9
Top = 600
Width = 735
End
Begin VB.CommandButton Command4
Caption = "退 出"
Height = 375
Left = 7200
TabIndex = 8
Top = 6840
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "浏 览"
Height = 255
Left = 7680
TabIndex = 7
Top = 240
Width = 735
End
Begin VB.CommandButton Command2
Caption = "复 制"
Height = 375
Left = 2280
TabIndex = 6
Top = 6840
Width = 1095
End
Begin VB.TextBox Text1
Height = 270
Left = 1200
TabIndex = 5
Top = 240
Width = 6255
End
Begin VB.ListBox List2
Height = 4920
Left = 4800
TabIndex = 2
Top = 1200
Width = 3615
End
Begin VB.ListBox List1
Height = 4920
Left = 960
TabIndex = 1
Top = 1200
Width = 3615
End
Begin VB.CommandButton Command1
Caption = "列 举"
Height = 375
Left = 960
TabIndex = 0
Top = 6840
Width = 1095
End
Begin VB.Label Label4
Caption = "目标目录:"
Height = 255
Left = 120
TabIndex = 12
Top = 600
Width = 855
End
Begin VB.Label Label3
Caption = "来源目录:"
Height = 255
Left = 120
TabIndex = 11
Top = 240
Width = 855
End
Begin VB.Label Label1
Alignment = 1 'Right Justify
Height = 375
Left = 3600
TabIndex = 4
Top = 6360
Width = 855
End
Begin VB.Label Label2
Height = 375
Left = 4800
TabIndex = 3
Top = 6360
Width = 1095
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private 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

Private getdir As String
Dim DirPath As String, DirPath1 As String
Private Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Msg) Then
bInfo.lpszTitle = "请选择目录:"
Else
bInfo.lpszTitle = Msg
End If

' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)

If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If

End Function

Private Sub FileSearch(ByVal sPath As String)
Dim Fpath As String
Static lngFiles As Long
Dim sDir As String
Dim sSubDirs() As String
Dim sDirs() As String
Dim lngIndex As Long, lngIndex1 As Long
Dim lngTemp&
Fpath = App.path & "\cfg.ini"
If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
DoEvents
lngIndex = 0
lngIndex1 = 0
sDir = Dir(sPath & "*.*", vbDirectory)

Do While Len(sDir)

If sDir <> "." And sDir <> ".." Then
lngIndex = lngIndex + 1
ReDim Preserve sSubDirs(1 To lngIndex)
sSubDirs(lngIndex) = sPath & sDir

If GetAttr(sPath & sDir) And vbDirectory Then
List1.AddItem Right(sSubDirs(lngIndex), Len(sSubDirs(lngIndex)) - Len(Text1.Text) - 1) & "\"
lngIndex1 = lngIndex1 + 1
ReDim Preserve sDirs(1 To lngIndex1)
sDirs(lngIndex1) = sSubDirs(lngIndex)
DoEvents
Else
List2.AddItem Right(sSubDirs(lngIndex), Len(sSubDirs(lngIndex)) - Len(Text1.Text) - 1)
DoEvents
End If

End If

sDir = Dir
Label1.Caption = "目录:" & List1.ListCount
Label2.Caption = "文件:" & List2.ListCount
Loop

Dim i

For i = 1 To lngIndex1
FileSearch sDirs(i)
Next i

End Sub

Private Sub Command1_Click()
If Trim(Text1.Text) = "" Or Dir(Text1.Text, vbDirectory) = "" Then MsgBox "来源目录不存在": Exit Sub
Command1.Enabled = False
Command2.Enabled = False
Command3.Enabled = False
List1.Clear
List2.Clear
FileSearch Text1.Text '
Command1.Enabled = True
Command2.Enabled = True
Command3.Enabled = True
End Sub

Private Sub Command2_Click()
If Trim(Text2.Text) = "" Or Dir(Text2.Text, vbDirectory) = "" Then MsgBox "目标目录不存在": Exit Sub

If Right(Trim(Text2.Text), 1) = "\" Then
DirPath = Trim(Text2.Text)
Else
DirPath = Trim(Text2.Text) & "\"
End If

If Right(Trim(Text1.Text), 1) = "\" Then
DirPath1 = Trim(Text1.Text)
Else
DirPath1 = Trim(Text1.Text) & "\"
End If

If List1.ListCount > 1 Then
Call 目录
Else
MsgBox "请先列举文件"
Exit Sub
End If

If List2.ListCount > 1 Then
Call 文件
Else
MsgBox "请先列举文件"
Exit Sub
End If

MsgBox "完成"
End Sub

Private Sub Command3_Click()
Text1.Text = GetDirectory
End Sub

Private Sub Command4_Click()
End
End Sub

Private Sub Command5_Click()
Text2.Text = GetDirectory
End Sub

Private Sub Form_Load()
Text1.Text = ""
End Sub

Private Sub 目录()
On Error Resume Next
Dim i As Integer

For i = 0 To List1.ListCount - 1

If Dir(DirPath & List1.List(i), vbDirectory) = "" Then
MkDir DirPath & List1.List(i)
End If

Next i

End Sub

Private Sub 文件()
On Error Resume Next
Dim i As Integer

For i = 0 To List2.ListCount - 1

If Dir(DirPath & List2.List(i), vbNormal) = "" Then
FileCopy (DirPath1 & List2.List(i)), DirPath & List2.List(i)
DoEvents
End If

Next i

End Sub