Oscar Sun

                  Option Explicit
Sub 檔案重新命名w() '原檔名有缺號，不連號者
On Error GoTo EHH
Dim fs, fc, fl, f, ef, i As Long, j As Long, frMat As String, 原檔起始號 As Long  ', OldName As String, NewName As String
'p = ""InputBox("請輸入路徑", , p)
Const p = "w:\!!scan\reName" '"請輸入路徑"
'Const p = "D:\千慮一得齋\資料庫\掃描資料庫\reName" '"請輸入路徑"
'If Dir(p) = "" Then MsgBox "請檢查路徑": Exit Sub
Const o = "" '被取代字串
Const n = "@@@" '取代字串

Const 卷 = ""
Const 新檔起始號 = 1

'Const 原檔起始號 = 1 '均先批次重新命名為１開始
Const 副檔名 = ".jpg"
If p = "" Then Exit Sub


Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(p)
Set fc = f.Files
'原檔起始號 = CLng(Mid(fc.Item(1), 2))
For Each fl In fc
    原檔起始號 = CLng(Mid(Replace(fl.Name, 副檔名, ""), 2))
    
    frMat = VBA.Replace(Replace(fl.Name, 副檔名, ""), 原檔起始號, "")
    frMat = frMat & VBA.String(Len(CStr(原檔起始號)), "0")
    Exit For
Next
For i = 0 To fc.Count - 1
    j = i
    If (i + 1) Mod 2 = 0 Then
'        fc(Format(i + 原檔起始號, "a00000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "b" & 副檔名)
        fc(Format(i + 原檔起始號, frMat & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "b" & 副檔名)
    Else
'        fc(Format(i + 原檔起始號, "a00000" & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "a" & 副檔名)
        fc(Format(i + 原檔起始號, frMat & 副檔名)).Name = Format(卷, "00000") & "_" & Format(Int(j / 2) + 新檔起始號, "000000" & "a" & 副檔名)
    End If
    i = j
Next i
'For Each fl In fc
'    fl.Name = Replace(fl.Name, o, n)
'
'Next fl
AppActivate "acdsee 5.0 - rename"
SendKeys "{f5}"
Exit Sub
EHH:
Select Case Err.Number
    Case 53 '找不到檔案
        Do
            i = i + 1
            For Each ef In fc
                If Format(i + 原檔起始號, "a00000" & 副檔名) = ef.Name Then Exit Do
            Next
        Loop
        Resume
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub