VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
楼主: acme_pjz

[分享] VB6的Unicode文件名支持

  [复制链接]
发表于 2014-4-6 00:30:26 | 显示全部楼层
谢谢
回复 支持 反对

使用道具 举报

发表于 2014-8-16 19:10:18 | 显示全部楼层
本帖最后由 kx25 于 2014-8-16 19:55 编辑

Name xx As xx 用 MoveFileW StrPtr(是Unicode), StrPtr(非Unicode) 代替:

Private Declare Function MoveFileW Lib "kernel32.dll" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long) As Long

将【Unicode文件路径】改成【 非 Unicode文件路径】,然后想干什么就干什么!

         MoveFileW 和 枚举 支持带“.\”的畸形路径
  1. Private Declare Function MoveFileW Lib "kernel32.dll" (ByVal lpExistingFileName As Long, ByVal lpNewFileName As Long) As Long

  2. Private Function SearchFilesDirW(ByRef CustomArray() As String, ByRef Amount As Long, _
  3.                                Optional ByVal FileFormat As String = "*", Optional ByVal sPath As String, _
  4.                                Optional vNote As String = "递归文件") As Boolean ' DIR递归文件(包括子目录、隐藏文件夹、系统文件夹)
  5.     '
  6.     Dim s As String, s1 As String, T$$$$, A&, V$$$$(), K&, L&, b As Boolean, R$$$$, NewDir$$$$, nd&, fold$$$$()
  7.     Dim i As VbFileAttribute
  8.     '
  9.     If Left(FileFormat, 1) <> ";" Then FileFormat = ";" & FileFormat
  10.     If Right(FileFormat, 1) <> ";" Then FileFormat = FileFormat & ";"
  11.     If Right(sPath, 1) <> "" Then sPath = sPath & ""
  12.     '
  13.     i = vbDirectory Or vbHidden Or vbSystem Or vbReadOnly Or vbNormal Or vbArchive
  14.     s = DirW(sPath, i)
  15.     Do Until s = vbNullString
  16.         If s Like "?*.?*" Then
  17.             If FileFormat = ";*;" Or Len(FileFormat) < 1 Then
  18.                 Call SetValueToStrArray(CustomArray, Amount, sPath & s)
  19.             Else
  20.                 A = InStrRev(s, ".")
  21.                 If A > 1 Then
  22.                     T = ";" & UCase(Mid(s, A + 1)) & ";"
  23.                     b = InStr(FileFormat, T)
  24.                     If b > 0 Then Call SetValueToStrArray(CustomArray, Amount, sPath & s)
  25.                 End If
  26.             End If
  27.         Else
  28.             If s <> "." And s <> ".." Then
  29.                 nd = nd + 1
  30.                 ReDim Preserve fold$$$$(nd)
  31.                 fold(nd) = sPath & s & ""
  32.                 fold(nd) = Replace(fold(nd), "\", "")
  33.                 If Right(fold(nd), 2) = "." Then fold(nd) = Left(fold(nd), Len(fold(nd)) - 2) & ".."
  34.             End If
  35.         End If
  36.         DoEvents
  37.         s = DirW
  38.     Loop
  39.     '
  40.     If nd > 0 Then
  41.         For K = 1 To nd
  42.             Call SearchFilesDirW(CustomArray, Amount, FileFormat, fold(K))
  43.             List1.AddItem fold(K)
  44.         Next
  45.     End If
  46. End Function
  47.                                                                     
  48. Private Function SetValueToStrArray(ArrayName() As String, ArrayAmount As Long, _
  49.                                     ByVal ArrayValue As String, Optional vNote As String = "字符串数组赋值") As Boolean
  50.     '
  51.     ArrayAmount = ArrayAmount + 1
  52.     ReDim Preserve ArrayName(1 To ArrayAmount) As String
  53.     ArrayName(ArrayAmount) = ArrayValue
  54. End Function

  55. Private Function SearchFolderDirW(ByRef CustomArray() As String, ByRef Amount As Long, _
  56.                                Optional ByVal sPath As String, Optional vNote As String = "递归子目录") As Boolean  ' DIR递归子目录(包括子目录、隐藏文件夹、系统文件夹)
  57.     '
  58.     Dim s As String, s1 As String, T$$$$, A&, V$$$$(), K&, L&, b As Boolean, R$$$$, NewDir$$$$, nd&, fold$$$$()
  59.     Dim i As VbFileAttribute
  60.     '
  61.     If Right(sPath, 1) <> "" Then sPath = sPath & ""
  62.     '
  63.     i = vbDirectory Or vbHidden Or vbSystem Or vbReadOnly Or vbNormal Or vbArchive
  64.     s = DirW(sPath, i)
  65.     Do Until s = vbNullString
  66.         If s Like "?*.?*" Then
  67.             '
  68.         Else
  69.             If s <> "." And s <> ".." Then
  70.                 nd = nd + 1
  71.                 ReDim Preserve fold$$$$(nd)
  72.                 fold(nd) = sPath & s & ""
  73.                 fold(nd) = Replace(fold(nd), "\", "")
  74.                 If Right(fold(nd), 2) = "." Then fold(nd) = Left(fold(nd), Len(fold(nd)) - 2) & ".."
  75.                 Call SetValueToStrArray(CustomArray, Amount, fold(nd))
  76.             End If
  77.         End If
  78.         DoEvents
  79.         s = DirW
  80.     Loop
  81.     '
  82.     If nd > 0 Then
  83.         For K = 1 To nd
  84.             Call SearchFolderDirW(CustomArray, Amount, fold(K))
  85.         Next
  86.     End If
  87. End Function

  88. Private Sub RenameFile(ByVal sOldName As String, ByVal sNewName As String)  ' 移动、重新命名文件夹或文件
  89.     MoveFileW StrPtr(sOldName), StrPtr(sNewName)
  90. End Sub
  91.                                                                     
  92. Private Sub Command4_Click()
  93.     Dim DF$$$$(), A&, i&, L&, K&, R$$$$, b As Boolean
  94.     '
  95.     'SearchFilesDirW DF, A, "*", TextBox1.Text    ' 递归文件
  96.     SearchFolderDirW DF, A, TextBox1.Text  ' 递归子目录
  97.     If A < 1 Then Exit Sub
  98.     '
  99.     List1.Clear
  100.     For i = A To 1 Step -1
  101.         Text2.Text = DF(i)  ' TextBox 会把不支持的字符换成: 英文问号
  102.         If InStr(1, Text2.Text, "?") > 0 Then ' 检查是否含有不支持的字符
  103.             R = Replace(Text2.Text, "?", "?")  ' 把不支持的字符换成: 中文问号
  104.             '最好循环检测一下【路径 R 】是否已经存在,存在就在文件名末端加编号。
  105.             Call RenameFile(DF(i), R)  ' 将【Unicode 路径】改成【 非 Unicode 路径】,
  106.             DF(i) = R  ' 将路径写回数组
  107.         End If
  108.         List1.AddItem DF(i)
  109.     Next
  110. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?立即注册

x

点评

这只是示范,改名后的重名问题,要自己去增加代码(重新命名可以是:时间+随机字符串;或者用2位随机英文数字替换VB不认识的字符《判断存在就循环命名直到不存在》)。  发表于 2014-8-17 17:38
已经标注:最好循环检测一下【路径 R 】是否已经存在,存在就在文件名末端加编号。  发表于 2014-8-17 17:30
要是有两个不同的文件名都包含VB不认识的字符,转换以后都变成问号了,那就重名了  发表于 2014-8-17 00:37
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-4 21:14

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表