长文档名称文档复制遇到的问题

大公臻信

各位老师：

长文档名文档  文件夹中有5个文档，我想将长文档名文档  文件夹中有5个文档复制到 长文档名文档2 文件夹中。代码如下：

Sub fzwjA()
'获取桌面路径
zmpath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
'源文件夹路径
opath = zmpath & "文件复制测试\长文档名文档\"
'新文件夹路径
ppath = zmpath & "文件复制测试\长文档名文档2\"
'If Dir(ppath, vbDirectory) <> "" Then
'    RmDir ppath
'End If
'MkDir (ppath)
Dim reg As Object
'创建正则对象
Set reg = CreateObject("VBScript.Regexp")
'汉字
reg.Pattern = "[\u4e00-\u9fa5]"
reg.Global = True
reg.IgnoreCase = True
'创建了一个FSO对象
Set fso = CreateObject("Scripting.FileSystemObject")
'错误处理
On Error Resume Next
'遍历文件夹获取文件
fname = Dir(opath)
If Err.Number = 0 Then
    '文件夹逐个文档循环处理
    Do While Len(fname) <> 0
        Debug.Print Left(fname, 5) & "  " & Len(fname)
        Set matches = reg.Execute(fname)
        CountZh = matches.Count
        zfzs = Len(fname) - CountZh + CountZh * 2
        Debug.Print Left(fname, 5) & "  " & zfzs
        '新文档名
        nfname = fname & Format(Date, "yyyymmdd")
        '新文档后缀名
        hzstr = "." & Split(opath & fname, ".")(1)
        '复制文档
        fso.Copyfile opath & fname, ppath & nfname & hzstr, overwritefiles:=True
        '清空源文档变量
        fname = ""
        On Error Resume Next
        '获取下一个文档
        fname = Dir()
    Loop
End If
End Sub

问题：
1、文件夹中第3个文档名称总字符数超260，dir函数获取不到此文档
2、当文件夹中遇到一个错误文档时跳出do while 循环，未处理文件夹中剩余的文档


请老师帮看看，指点一下，谢谢

huarong7984

文档路径名称总长度不得大于247个英文字符

huarong7984

若文档路径名称大于247个英文字符，可采用：1、提升目标文档的保存层级，以减少路径名称的字符数；2、减少路径层级中，各文件夹名称的字符数，即精减各层级的文件夹名称，使路径的总字符数小于247即可

大公臻信

谢谢huarong7984老师，请问怎样自动实现提升目标文档的保存层级、减少路径层级等目标，达到批量处理的最终效果

limonet

给个附件，多打草稿。

perfect131

大公臻信 发表于 2024-6-1 09:06
谢谢huarong7984老师，请问怎样自动实现提升目标文档的保存层级、减少路径层级等目标，达到批量处理的最终 ...

用 SHFileOperation 即可

perfect131

perfect131 发表于 2024-6-1 10:45
用 SHFileOperation 即可

解决dir 文件名限制

大公臻信

谢谢perfect131老师

大公臻信

#If VBA7 Then
    Private Declare PtrSafe Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
#Else
    Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
#End If
老师，我的电脑安装Windows 10带Office 为何#else后一句显示红色。请指点一下。谢谢