unicode字元檔名轉換＿避免非Big5字成「?」問號 vbscript 

                  Function unicode字元檔名轉換() '以利燒錄與ACDSee存取也.2006/11/21
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fc, fl, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then P = "D:\Users\ssz3\Downloads\簡反正後上傳" '"W:\Emule\新資料夾"
P = InputBox("請輸入路徑", , P)
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P)
Set fc = f.files
For Each fl In fc
    OldName = fl.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fl.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
Next
rst.Close
CurrentDb.Close
For Each fl In fc '轉換uvz檔名
    If InStr(fl.Name, ".uvz.zip") Then
        fl.Name = Replace(fl.Name, ".uvz.zip", ".uvz")
    End If
Next
MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function
Function unicode字元檔名轉換_Folder() '20190907子資料夾重新命名
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fSubs, fSub, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then P = "D:\Users\ssz3\Downloads\簡反正後上傳" '"W:\Emule\新資料夾"
P = InputBox("請輸入路徑", , P)
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P) 'folder
Set fSubs = f.subfolders
For Each fSub In fSubs
    OldName = fSub.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fSub.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fSub.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & _
                                            Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fSub.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & _
                                        Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fSub.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    q = q + unicode字元檔名轉換_subfolderFiles(fSub.Path)
Next
rst.Close
CurrentDb.Close
MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function

Function unicode字元檔名轉換_subfolderFiles(P As String) As Long '子資料夾中的檔案
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fc, fl, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P)
Set fc = f.files
For Each fl In fc
    OldName = fl.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fl.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
Next
rst.Close
CurrentDb.Close
For Each fl In fc '轉換uvz檔名
    If InStr(fl.Name, ".uvz.zip") Then
        fl.Name = Replace(fl.Name, ".uvz.zip", ".uvz")
    End If
Next
'MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
unicode字元檔名轉換_subfolderFiles = q
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function
View Oscar's Profile