Fioの素敵な日々

■[Mery][VBScript]一行目をファイル名にして保存するマクロ

一行目が空行だったら二行目（以下同じ）を対象にします。一行目が長すぎる時は適当に削って、ファイル名にできない文字が含まれている時は変換します。同じファイル名があったら、ファイル名(1).txtのように名前に連番をつけます。
ちょっと前に作ってEmEditorで使っていたのを修正したので、基本的にEmEditorでも動きますが、EmEditorのマクロにはDocument.GetLineというコマンドがあるので、これを使って一行目を取得した方が効率的だと思います。Document.Textで文全体を取得するのは、巨大なファイルの場合は大変ですからねえ（巨大なファイルになる前に通常は保存すると思いますが）。
Meryのマクロを作る際に気をつけなければならないのは、Document.Textでテキスト全体を取得する時はvbCrLf(\r\n)区切りなのですが、Document.Selection.Textで選択範囲を取得するとvbLf(\n)区切りになっていることです*1。JavaScript系の場合は改行と言えば\nが使われる影響と思いますが、将来どちらかに仕様変更されると思いますので、その時に修正が必要です。ちなみに、EmEditorの場合は、どちらもvbCrLf(\r\n)区切りが使われています。(シフト JISでCL+LFの改行指定の場合）

'一行目をファイル名にして保存.vbs
'一行目をファイル名にして保存します
'本文がない場合は、年月日をファイル名にします
'すでに同じファイル名がある場合は、(1)など連番をつけます

'保存するフォルダと拡張子を指定して下さい
Const FolderPath = "C:\home"
Dim ExtName : ExtName = ".txt"

Set FS = CreateObject("Scripting.FileSystemObject")

'フォルダのチェック
If Not FS.FolderExists(FolderPath) then
  MsgBox "指定したフォルダが見つかりません"
  WScript.Quit
End If

'一行目が空行の場合は次の行にします（以下同じ）
For Each line in Split(Document.Text, vbCrLf)
  If line<>"" then
    Title = line
    Exit For
  End If
Next
'本文が何もない場合は、年月日をファイル名にします
If Title="" then Title=Year(Date) & "-" & _
  Right("0" & Month(Date),2) & "-" & Right("0" & Day(Date),2)
'ファイル名に使えない文字を変換します
Title = fixUnFileNameCodes(Title)
'ファイル名が長すぎる場合は、50文字くらいに
Title = Left(Title, 50)

If Not Left(ExtName, 1)="." then ExtName = "." & ExtName
FilePath = FS.BuildPath(FolderPath, Title & ExtName)
FilePath = CheckFilePath(FilePath)
Document.Save FilePath


Private Function fixUnFileNameCodes(inStr)
  '\ / , ; : * ? " < > | はファイル名として使えない
  outStr = Replace(inStr, "\", "￥")
  outStr = Replace(outStr, "/", "／")
  outStr = Replace(outStr, ",", "、")
  outStr = Replace(outStr, ";", "；")
  outStr = Replace(outStr, ":", "：")
  outStr = Replace(outStr, "*", "＊")
  outStr = Replace(outStr, "?", "？")
  outStr = Replace(outStr, "<", "＜")
  outStr = Replace(outStr, ">", "＞")
  outStr = Replace(outStr, "|", "｜")
  outStr = Replace(outStr, """", "”")
  outStr = Replace(outStr, vbTab, " ")
  outStr = Replace(outStr, vbCr, "")
  outStr = Replace(outStr, vbLf, "")
  outStr = Replace(outStr, Chr(0), "")
  outStr = Replace(outStr, Chr(11), "")
  fixUnFileNameCodes = outStr
End Function

Private Function CheckFilePath(FilePath)
  '同じ名前のファイルがあったら(1)など連番をつける
  Dim tmpFolderPath, tmpFileName, tmpExtName, tmpFilePath
  If FS.FileExists(FilePath) then
    tmpFolderPath = FS.GetParentFolderName(FilePath)
    tmpFileName = FS.GetBaseName(FilePath)
    tmpExtName = FS.GetextensionName(FilePath)
    If Not Left(tmpExtName, 1)="." then tmpExtName = "." & tmpExtName
    For i = 1 to 1000 '1000以上同じ名前がありそうな時は増やしてね
      tmpFilePath = FS.BuildPath(tmpFolderPath, tmpFileName & "(" & i & ")" & tmpExtName)
      If Not FS.FileExists(tmpFilePath) then Exit For
    Next
  Else
    tmpFilePath = FilePath
  End If
  CheckFilePath = tmpFilePath
End Function

ツイートする

Permalink