Re: [請問] 把.txt檔名自動改為內文第一行文

[hpo14 (雨)]

重新修正了一下，本來的 Select Case 部份沒寫好，造成使用上會有 Bug

感謝 sanbis 提醒。

另外提醒：因系統的參數列長度限制 255 字元，故能夠拖曳的檔案數量
          會因為檔名長度而變動。

版本 1: 直接拖檔案到 vbs 檔
-----------------------8<--------------------- 複製虛線內文另存 VBS 檔
Dim objFSO    : Set objFSO = CreateObject("Scripting.FileSystemObject")

If Wscript.Arguments.Count <> 0 Then
    Dim FilePath()
    For i = 0 to Wscript.Arguments.Count - 1
        '// 設定預設編碼格式
        Redim Preserve FilePath(i)
        FilePath(i) = Wscript.Arguments(i)
        Dim Line1 : Line1 = GetLine1(FilePath(i))
        Set objFile0 = objFSO.GetFile(FilePath(i))
        path = objFSO.GetParentFolderName(objFile0)
        ext = objFSO.GetExtensionName(objFile0)
        newpath = path & "\" & Line1 & "." & ext
        objFSO.MoveFile FilePath(i), newpath
   Next
End If

Function GetLine1(filename)
    Dim stream : set stream = CreateObject("ADODB.Stream")
    stream.Type = 2
    stream.Charset = "437"
    stream.Open
    stream.LoadFromFile(filename)
    Dim bom : bom = Escape(stream.ReadText(2))
    stream.Close
    Select case bom
        case "%u2229%u2557"    '// UTF-8 Signature
            stream.Charset = "UTF-8"
        case "%B5%F2"
            stream.Charset = "UTF-8"
        case "%A0%u25A0"       '// UTF-16 LE BOM
            stream.Charset = "Unicode"
        case "%u25A0%A0"       '// UTF-16 BE BOM
            stream.Charset = "Unicode"
        case "%5De"            '// UTF-16 LE
            stream.Charset = "Unicode"
        case "e%5D"            '// UTF-16 BE
            stream.Charset = "Unicode"
        case else
            stream.Charset = "Big5"   '// 預設定為 Big5(950) 編碼
    End Select
    stream.Open
    stream.LoadFromFile(filename)
    GetLine1 = stream.ReadText(-2)
    stream.Close
    Set stream = Nothing
End Function
-----------------------8<--------------------- 複製虛線內文另存 VBS 檔

版本 2: 拖資料夾到 vbs 檔上 (要改名的檔案全部放到該資料夾)
-----------------------8<--------------------- 複製虛線內文另存 VBS 檔
Dim objFSO : Set objFSO = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count <> 0 Then
    Dim root   : root = WScript.Arguments(0)
    Dim folder : set folder = objFSO.GetFolder(root)
    Dim files  : set files = folder.files
    Dim fname, oldpath, newpath

    If files.Count <> 0 Then
        For each f in files
            oldpath = root & "\" & f.Name
            fname = GetLine1(oldpath)
            newpath = root & "\" & fname & "." & Split(f.Name, ".")(1)
            Do While objFSO.FileExists(newpath)
                newpath = root & "\" & fname & "-" & _
                          Split(objFSO.GetTempName, ".")(0) & "." & _
                          Split(f.Name, ".")(1)
            Loop
            objFSO.MoveFile oldpath, newpath
       Next
    End If
End If

Function GetLine1(filename)
    Dim stream : set stream = CreateObject("ADODB.Stream")
    stream.Type = 2
    stream.Charset = "437"
    stream.Open
    stream.LoadFromFile(filename)
    Dim bom : bom = Escape(stream.ReadText(2))
    stream.Close
    If (strcomp(bom, "%u2229%u2557") or strcomp(bom, "%B5%F2")) Then
        stream.Charset = "UTF-8"
    Elseif (strcomp(bom,"%A0%u25A0") or strcomp(bom, "%u25A0%A0") or _
              strcomp(bom, "%5De") or strcomp(bom, "e%5D")) Then
        stream.Charset = "Unicode"
    Else
        stream.Charset = "Big5"
    End If
    stream.Open
    stream.LoadFromFile(filename)
    GetLine1 = stream.ReadText(-2)
    stream.Close
End Function
-----------------------8<--------------------- 複製虛線內文另存 VBS 檔

--
※ 發信站: 批踢踢實業坊(ptt.cc)
◆ From: 123.204.46.87
→ hpo14:咦，不是應該 s 嗎？
※ 編輯: hpo14           來自: 123.204.46.87        (10/06 23:00)