日付形式ファイル保存マクロ（拡張子自動判別） - EmEditorみんなでまとめサイト

概要

日付形式ファイル保存マクロ を改造して、現在の設定の拡張子を自動的に付加するようにしたマクロです。

現在の日付から作成されたファイル名で保存できます。メニューから拡張子を選択できるようにしました。 Visual Basic なので拡張子 .vbee で保存する必要があります。

ダウンロード

• version 0.04
  • datesave04.zip
    • 「年」2ケタに対応する「yy」を追加しました

コメント

• ご意見・ご感想・ご要望　何かあればどぞー -- Nanasiya
• version 0.01 にはバグがあったので修正しました。ダウンロードされた方は差し替えをお願いします。 -- Nanasiya
• 乙。ファイル名はひとつでいいから、逆に拡張子を選べるようにしてほしいな。 --
• 拡張子をトップメニューにできるようにしました。ExtTopMenu を1にしてみてください。 -- Nanasiya
• 日付をyyで取得できませんか？ --
• 「年」2ケタって事ですよね？　追加してみました。「yyyy」の方が優先されます。 -- Nanasiya
• ありがとうございました -- yyのお願いをした人

コード

'****
' 日付形式ファイル保存マクロ（拡張子自動判別） version 0.04
' Created by Nanasiya
'
' 改造・再配布等、ご自由にご利用ください。
'****

Option Explicit
Dim DefaultExt, Dir, AskBefore, FormatList, ExtTopMenu, QuickSave

'*** 設定ここから ***

' デフォルトの拡張子リスト
DefaultExt = Array( _
    ".txt", _
    "" _
)

' 保存先のフォルダ ("C:\Temp" など)
Dir = ""

' 保存する前に確認するか（確認する=1, 確認しない=0）
AskBefore = 1

' 使用するファイル名のフォーマットリスト
FormatList = Array( _
    "yyyymmdd", _
    "yymmdd", _
    "yyyy-mm-dd", _
    "yyyy年mm月dd日", _
    "yyyymmddhhMMss", _
    "yyyy年mm月dd日hh時MM分ss秒" _
)

' フォーマット選択がトップメニュー = 0
' 拡張子選択がトップメニュー       = 1
ExtTopMenu = 0

' クイックセーブするか（する=1, しない=0）
' FormatList の最初のフォーマット、検出された最初の拡張子が使われます
QuickSave = 0

'*** 設定ここまで ***

'--- 以下メイン処理 ---
Dim Shell, FSO
Dim ExtList, Base, Ext, I

Set Shell = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")

If Dir = "" Or Not FSO.FolderExists(Dir) Then
    Dir = Shell.SpecialFolders("MyDocuments")
End If

For I = LBound(FormatList) To UBound(FormatList)
    FormatList(I) = FormatFileName( FormatList(I) )
Next
Base = FormatList(0)

ExtList = GetConfigExtensions(document.ConfigName, DefaultExt)
Ext = ExtList(0)

' メニューループ
If QuickSave = 0 Then
    Dim Menu, Sel
    Do
        Set Menu = BuildMenu(FormatList, ExtList, Base, Ext)
        Sel = Menu.Track(0) - 1

        If Sel = -1 Then
            Quit
        ElseIf Sel <= UBound(FormatList) Then
            Base = FormatList(Sel)
            If ExtTopMenu = 0 Then Exit Do
        Else
            Ext = ExtList(Sel - UBound(FormatList) - 1)
            If ExtTopMenu <> 0 Then Exit Do
        End If
    Loop
End If

' 保存処理
Dim FileName
FileName = FSO.BuildPath(Dir, Base & Ext)

If AskBefore <> 0 Then
    If Not confirm("以下で保存します。よろしいですか？" _
                   & vbCrLf & vbCrLf & FileName) _
    Then Quit
End If

If FSO.FileExists(FileName) Then
    If Not confirm("同名のファイルが存在します。上書きしますか？" _
                   & vbCrLf & vbCrLf & FileName) _
    Then Quit
End If

document.Save(FileName)

'--- 以下サブルーチン ---

' ファイル名を日時でフォーマット
Function FormatFileName(ByVal Format)
    Dim Current, FileName
    Current = Now
    FileName = Format
    FileName = Replace(FileName, "yyyy", ZeroPad(Year(Current)))
    FileName = Replace(FileName, "yy",   ZeroPad(Year(Current) mod 100))
    FileName = Replace(FileName, "mm",   ZeroPad(Month(Current)))
    FileName = Replace(FileName, "dd",   ZeroPad(Day(Current)))
    FileName = Replace(FileName, "hh",   ZeroPad(Hour(Current)))
    FileName = Replace(FileName, "MM",   ZeroPad(Minute(Current)))
    FileName = Replace(FileName, "ss",   ZeroPad(Second(Current)))
    FormatFileName = FileName
End Function

' 2桁のゼロ埋め
Function ZeroPad(ByVal Num)
    ZeroPad = CStr(Num)
    If Len(ZeroPad) < 2 Then ZeroPad = "0" & ZeroPad
End Function

' メニュー作成
Function BuildMenu(ByRef FormatList, ByRef ExtList, ByVal Base, ByVal Ext)
    Dim TopMenu, SubMenu
    Set TopMenu = CreatePopupMenu
    Set SubMenu = CreatePopupMenu

    If ExtTopMenu <> 0 Then
        BuildExtMenu TopMenu, ExtList, Ext, UBound(FormatList) + 2
        BuildFormatMenu SubMenu, FormatList, Base, Ext, 1
        TopMenu.Add "", 0, eeMenuSeparator
        TopMenu.AddPopup "ファイル名(&F) " & Base & Ext, SubMenu
    Else
        BuildFormatMenu TopMenu, FormatList, Base, Ext, 1
        BuildExtMenu SubMenu, ExtList, Ext, UBound(FormatList) + 2
        TopMenu.Add "", 0, eeMenuSeparator
        TopMenu.AddPopup "拡張子(&E) " & Ext, SubMenu
    End If

    TopMenu.Add "", 0, eeMenuSeparator
    TopMenu.Add "キャンセル(&C)", 0

    Set BuildMenu = TopMenu
End Function

' フォーマットリストのメニュー作成
Sub BuildFormatMenu(ByRef Menu, ByRef FormatList, ByRef Base, ByRef Ext, ByVal StartIndex)
    Dim I, Flag
    For I = LBound(FormatList) To UBound(FormatList)
        If ExtTopMenu <> 0 And FormatList(I) = Base Then Flag = eeMenuChecked Else Flag = 0
        Menu.Add "&" & I & " " & FormatList(I) & Ext, I + StartIndex, Flag
    Next
End Sub

' 拡張子リストのメニュー作成
Sub BuildExtMenu(ByRef Menu, ByRef ExtList, ByRef Ext, ByVal StartIndex)
    Dim I, Flag
    For I = LBound(ExtList) To UBound(ExtList)
        If ExtTopMenu = 0 And ExtList(I) = Ext Then Flag = eeMenuChecked Else Flag = 0
        Menu.Add "&" & I & " " & ExtList(I), I + StartIndex, Flag
    Next
End Sub

' バイト配列 Arr の From から4バイトを Integer にして返す
Function ReadInteger(ByRef Arr, ByVal From)
    Dim I
    ReadInteger = 0
    For I = 0 To 3
        ReadInteger = ReadInteger + Arr(I+From) * 256^I
    Next
End Function

' バイト配列 Arr の From から Length の長さの Unicode 文字列を String にして返す
Function ReadWString(ByRef Arr, ByVal From, ByVal Length)
    Dim I, W
    ReadWString = ""
    For I = 0 To Length-1
        W = Arr(From + I*2)
        W = W + Arr(From + I*2 + 1) * 256
        ReadWString = ReadWString & ChrW(W)
    Next
End Function

' ConfigName の設定に関連付けられている拡張子リストを取得する
Function GetConfigExtensions(ByVal ConfigName, ByVal DefaultExt)
    Dim Path, Arr, Count, I, Index, Length, Ext()

    Path = "HKCU\Software\EmSoft\EmEditor v3\Config\" & ConfigName & "\Assoc"
    Set Shell = CreateObject("WScript.Shell")

    Arr = Shell.RegRead(Path)
    Count = ReadInteger(Arr, 5)  ' 拡張子の数 5byte目から

    If Count <= 0 Then
        GetConfigExtensions = DefaultExt
        Exit Function
    End If

    ReDim Ext(Count-1)
    Index = 9
    For I = 0 To Count-1
        If Arr(Index) <> 1 Then Exit For
        Index = Index + 1

        Length = ReadInteger(Arr, Index)
        Ext(I) = "." & LCase(ReadWString(Arr, Index+4, Length))
        Index = Index + 4 + Length * 2
    Next

    ' 動的配列→Variant配列変換
    Dim Code, S
    Code = "Array("
    For Each S In Ext
        If S <> "" Then
            If Code <> "Array(" Then Code = Code & ","
            Code = Code & """" & S & """"
            DefaultExt = Filter(DefaultExt, S, False, 1)
        End If
    Next
    For Each S In DefaultExt
        If Code <> "Array(" Then Code = Code & ","
        Code = Code & """" & S & """"
    Next
    Code = Code & ")"
    GetConfigExtensions = Eval(Code)
End Function

Changelog

• Version 0.04
  • 「年」2ケタに対応する「yy」を追加しました
• Version 0.03
  • デフォルト拡張子を複数設定できるようにしました
  • ExtTopMenu オプションを作成してトップメニューを選択できるようにしました
  • クイックセーブオプションを作成しました