最近bvaやってるんだけど、そこで使えそうな関数とか生成できたら共有したい(個人アウトプット用)

@echo off
setlocal enabledelayedexpansion

set total_lines=0

:: カレントディレクトリの全ての.logファイルを対象に
for %%f in (*.log) do (
    :: ファイルが空でないかを確認
    for /f %%a in ('findstr /r /v "^$" "%%f" ^| find /c /v ""') do (
        if %%a gtr 0 (
            set /a total_lines+=%%a
        )
    )
)

echo Total lines (excluding empty lines and empty files): %total_lines%
pause
endlocal

Sub testCreateDictForSophiaKosho()
    Dim dict As Object
    Dim filePath As String
    Dim key As Variant
    
    filePath = "C:\path\to\your\file.xlsx"
    Set dict = createDictForSophiaKosho(filePath)
    
    ' 辞書の中身を確認
    For Each key In dict.Keys
        Debug.Print "Key: " & key & ", Value: " & dict(key)
    Next key
End Sub

' 引数：Excelファイルのパス
' 機能：2行目以降のA列を辞書のKeyに、E列またはH列に1があればValueにTrueを設定して返す
Function createDictForSophiaKosho(filePath As String) As Object
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim dict As Object
    Dim lastRow As Long
    Dim i As Long
    
    ' 辞書を作成
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' ワークブックを開く
    Set wb = Workbooks.Open(filePath)
    Set ws = wb.Sheets(1) ' シート1を対象とする
    
    ' 最終行を取得
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 2行目から最終行まで処理
    For i = 2 To lastRow
        Dim key As String
        Dim value As Boolean
        key = ws.Cells(i, "A").Value
        value = (ws.Cells(i, "E").Value = 1 Or ws.Cells(i, "H").Value = 1)
        
        ' 辞書にKeyとValueを追加
        If Not dict.exists(key) Then
            dict.Add key, value
        End If
    Next i
    
    ' ワークブックを閉じる（保存しない）
    wb.Close SaveChanges:=False
    
    ' 辞書を返す
    Set createDictForSophiaKosho = dict
End Function

Function GetExcelFilePath() As String
    Dim fd As FileDialog
    Dim selectedFile As String

    ' FileDialogオブジェクトを作成
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    
    ' ダイアログの設定
    With fd
        .Title = "Excelファイルを選択してください" ' ダイアログのタイトル
        .Filters.Clear
        .Filters.Add "Excelファイル", "*.xls; *.xlsx; *.xlsm" ' フィルタの設定
        .AllowMultiSelect = False ' 複数選択不可
        
        ' ダイアログを表示し、ユーザーがファイルを選択した場合
        If .Show = -1 Then
            selectedFile = .SelectedItems(1) ' 選択されたファイルのパスを取得
            GetExcelFilePath = selectedFile
        Else
            ' キャンセルされた場合は空文字を返す
            GetExcelFilePath = ""
        End If
    End With

    ' オブジェクトをクリーンアップ
    Set fd = Nothing
End Function

Function CombineFolderPathWithFileNames(ByVal folderPath As String, ByVal fileNames() As String) As String()
    Dim combinedFilePaths() As String
    Dim i As Integer
    
    ' 配列のサイズをファイル名の配列と同じにする
    ReDim combinedFilePaths(LBound(fileNames) To UBound(fileNames))
    
    ' 各ファイル名の前にフォルダパスを結合
    For i = LBound(fileNames) To UBound(fileNames)
        combinedFilePaths(i) = folderPath & "\" & fileNames(i)  ' フォルダパスとファイル名を結合
    Next i
    
    ' 結果の配列を返す
    CombineFolderPathWithFileNames = combinedFilePaths
End Function

Sub exampleUsage()
    Dim progress As ProgressMeter
    Set progress = New ProgressMeter
    
    ' 全体の値を設定
    progress.SetTotal 10
    
    ' 現在の進捗度を1から10までループ
    Dim current As Integer
    For current = 1 To 10
        ' 現在の進捗を設定
        progress.SetCurrent current
        
        ' 進捗メーターをDebug.Printで出力
        Debug.Print "Current: " & current & " - Progress Bar: " & progress.GetProgressBar & " - Percent: " & progress.GetProgressPercent & "%"
    Next current
End Sub

' ProgressMeterクラス
Option Explicit

Private Const BAR_LENGTH As Integer = 10  ' 進捗バーの長さ
Private Const OPENING_BRACKET As String = "["  ' 開始括弧
Private Const CLOSING_BRACKET As String = "]"  ' 終了括弧
Private Const FILL_CHARACTER As String = "#"   ' 充填部分の文字
Private Const EMPTY_CHARACTER As String = "　"   ' 空白部分の文字

Private m_progressBar As String  ' 進捗メーター
Private m_current As Integer  ' 現在の進捗度
Private m_total As Integer  ' 全体の値

' 現在の進捗度を設定するメソッド
Public Sub SetCurrent(ByVal current As Integer)
    m_current = current
    UpdateProgressBar
End Sub

' 全体の値を設定するメソッド
Public Sub SetTotal(ByVal total As Integer)
    m_total = total
    UpdateProgressBar
End Sub

' 進捗バーを更新するメソッド
Private Sub UpdateProgressBar()
    If m_total > 0 Then
        Dim filledLength As Integer
        filledLength = Application.WorksheetFunction.RoundUp(BAR_LENGTH * m_current / m_total, 0)
        
        ' 進捗バーの生成
        m_progressBar = OPENING_BRACKET
        
        ' 充填部分を追加
        Dim i As Integer
        For i = 1 To filledLength
            m_progressBar = m_progressBar & FILL_CHARACTER
        Next i
        
        ' 空白部分を追加
        Dim emptyLength As Integer
        emptyLength = BAR_LENGTH - filledLength
        For i = 1 To emptyLength
            m_progressBar = m_progressBar & EMPTY_CHARACTER
        Next i
        
        m_progressBar = m_progressBar & CLOSING_BRACKET  ' 終了のブラケットを追加
    Else
        m_progressBar = OPENING_BRACKET & EMPTY_CHARACTER & CLOSING_BRACKET
    End If
End Sub

' 進捗メーターを取得するゲッター
Public Function GetProgressBar() As String
    GetProgressBar = m_progressBar
End Function

' 進捗度を取得するゲッター
Public Function GetProgressPercent() As Double
    If m_total > 0 Then
        GetProgressPercent = (m_current / m_total) * 100
    Else
        GetProgressPercent = 0
    End If
End Function

Function GetRowValues(targetRow As Long) As Variant
    Const EXCLUDE_VALUE As String = "ー"
    Dim ws As Worksheet
    Dim lastCol As Long
    Dim values As Collection
    Dim cell As Range
    Dim result() As Variant
    Dim i As Long

    ' 使用中のシートを設定
    Set ws = ThisWorkbook.ActiveSheet

    ' 指定行の最終列を取得
    lastCol = ws.Cells(targetRow, ws.Columns.Count).End(xlToLeft).Column

    ' 値を格納するコレクションを初期化
    Set values = New Collection

    ' 指定行のB列から最終列までをループ
    For Each cell In ws.Range(ws.Cells(targetRow, 2), ws.Cells(targetRow, lastCol))
        If cell.Value <> EXCLUDE_VALUE Then
            values.Add cell.Value
        End If
    Next cell

    ' 結果を配列に変換
    ReDim result(1 To values.Count)
    For i = 1 To values.Count
        result(i) = values(i)
    Next i

    ' 関数の戻り値を設定
    GetRowValues = result
End Function

Function FilePathsToFSOCollection(filePaths As Variant) As Collection
    ' Scripting.FileSystemObject を作成
    Dim fso As New Scripting.FileSystemObject
    Dim fileCollection As New Collection
    Dim i As Long
    
    ' 各ファイルパスを確認して存在するファイルだけを Collection に追加
    For i = LBound(filePaths) To UBound(filePaths)
        If fso.FileExists(filePaths(i)) Then
            fileCollection.Add fso.GetFile(filePaths(i))
        End If
    Next i
    
    ' FSO オブジェクトの Collection を返す
    Set FilePathsToFSOCollection = fileCollection
End Function

Function GetTableReference(ByRef cell As Range) As String
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim tableName As String
    Dim columnName As String
    Dim rowNumber As Long
    
    ' アクティブセルが含まれるシートを取得
    Set ws = cell.Worksheet
    
    ' ワークシートのすべてのテーブルを確認
    For Each tbl In ws.ListObjects
        ' テーブルの範囲にセルが含まれているかを確認
        If Not Intersect(cell, tbl.Range) Is Nothing Then
            ' テーブル名を取得
            tableName = tbl.Name
            
            ' ヘッダー行にいる場合
            If cell.Row = tbl.HeaderRowRange.Row Then
                ' テーブル内のセルの列名を取得
                columnName = tbl.HeaderRowRange.Cells(1, cell.Column - tbl.Range.Column + 1).Value
                GetTableReference = "Table Name: " & tableName & ", Column Header: " & columnName & " (Header Row)"
            ' データボディ部分にいる場合
            ElseIf Not Intersect(cell, tbl.DataBodyRange) Is Nothing Then
                ' テーブル内のセルの列名を取得
                columnName = tbl.ListColumns(cell.Column - tbl.Range.Column + 1).Name
                
                ' テーブル内のセルの行番号を取得 (データボディ部分の行番号)
                rowNumber = cell.Row - tbl.DataBodyRange.Row + 1
                
                ' テーブル内の参照を文字列として返す
                GetTableReference = "Table Name: " & tableName & ", Column: " & columnName & ", Row: " & rowNumber
            Else
                ' テーブルの範囲内であっても、ヘッダーやデータボディ以外の場所にいる場合
                GetTableReference = "ActiveCellはテーブルの範囲内ですが、ヘッダーやデータボディ以外の場所にいます。"
            End If
            
            Exit Function
        End If
    Next tbl
    
    ' セルがテーブルに属していない場合
    GetTableReference = "ActiveCellはテーブル内にありません。"
End Function

Function GetCellName(ByRef cell As Range) As String
    Dim cellName As String
    Dim nm As Name
    
    ' セルのアドレスを取得
    Dim cellAddress As String
    cellAddress = cell.Address
    
    ' 名前を調べる
    For Each nm In ThisWorkbook.Names
        If InStr(1, nm.RefersTo, cellAddress) > 0 Then
            cellName = nm.Name
            Exit For
        End If
    Next nm
    
    ' 名前が見つかった場合はそれを返す
    If cellName <> "" Then
        GetCellName = cellName
    Else
        GetCellName = "名前はありません"
    End If
End Function

Function listBoxToArr(lst As Variant) As String()
    Dim rowCount As Integer
    Dim i As Integer
    Dim result() As String
    
    ' ListBoxが空かどうかをチェック
    If Not IsEmpty(lst) Then
        ' ListBoxの行数を取得
        rowCount = UBound(lst, 1) - LBound(lst, 1) + 1
        
        ' 一次元配列のサイズを設定
        ReDim result(1 To rowCount)
        
        ' 最初の列の値を一次元配列にコピー
        For i = 1 To rowCount
            result(i) = lst(i - 1, 0)
        Next i
    Else
        ' 空の場合は空の配列を返す
        ReDim result(1 To 0)
    End If
    
    GetFirstColumnValues = result
End Function

Function ArrayToNewLineString(arr As Variant) As String
    Dim result As String
    Dim i As Integer
    
    For i = LBound(arr) To UBound(arr)
        result = result & arr(i) & vbCrLf
    Next i
    
    ' 最後の改行を削除する
    If Len(result) > 0 Then
        result = Left(result, Len(result) - Len(vbCrLf))
    End If
    
    ArrayToNewLineString = result
End Function

Function SplitByNewLine(ByVal inputString As String) As Variant
    ' 改行コードで文字列を分割して配列にする
    Dim result As Variant
    result = Split(inputString, vbCrLf)
    
    ' 戻り値として配列を返す
    SplitByNewLine = result
End Function

Dim ws As Worksheet
Dim tbl As ListObject

Private Sub Class_Initialize()
    Set ws = ThisWorkbook.Sheets("macro")
    Set tbl = ws.ListObjects("MacroTable")
End Sub

Function GetValueFromTable(rowNum As Integer, colNum As Integer) As String
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim cellValue As String
    
    ' シート名を指定してワークシートを取得
    Set ws = ThisWorkbook.Sheets("Sheet1")
    
    ' テーブル名を指定してテーブルを取得
    Set tbl = ws.ListObjects("Table1")
    
    ' 指定した行と列のセルの値を取得
    cellValue = tbl.DataBodyRange.Cells(rowNum, colNum).Value
    
    ' 文字列型で値を返す
    GetValueFromTable = CStr(cellValue)
End Function

' 配列を受け取り、その文字列たちを含む行とマッチする正規表現パターンを生成する
Function BuildRegexPattern(keywords As Variant) As String
    Dim pattern As String
    Dim i As Integer
    
    ' 正規表現の始まりを設定
    pattern = ".*("
    
    ' 各キーワードを正規表現パターンに追加
    For i = LBound(keywords) To UBound(keywords)
        ' 最初の要素以外の場合はパイプ(|)で区切る
        If i > LBound(keywords) Then
            pattern = pattern & "|"
        End If
        pattern = pattern & keywords(i)
    Next i
    
    ' 正規表現の終わりを設定
    pattern = pattern & ").*"
    
    ' 完成した正規表現パターンを返す
    BuildRegexPattern = pattern
End Function

Function HasPrefix(inputStr As String, targetPrefixStr As String) As Boolean
    ' 指定された文字列の先頭がターゲットプレフィックスで始まっているかを判断する
    If Len(targetPrefixStr) = 0 Then
        HasPrefix = False ' プレフィックスが空の場合はFalseを返す
        Exit Function
    End If
    
    If Left(inputStr, Len(targetPrefixStr)) = targetPrefixStr Then
        HasPrefix = True ' プレフィックスが一致する場合はTrueを返す
    Else
        HasPrefix = False ' 一致しない場合はFalseを返す
    End If
End Function

Sub onButtonClicked()
    Dim folderPath As String
    Dim filenamePrefix As String: filenamePrefix = "選別後_"
    Dim targetExtension As String: targetExtension = "log"
    Dim charset As String: charset = "utf-8"
    folderPath = InputFolderAsFolderPath()
    If folderPath = "" Then Exit Sub

    Call ConvertLogFiles(folderPath, filenamePrefix, targetExtension, charset)
    MsgBox "処理完了"
End Sub

Sub ConvertLogFiles(inputFolderPath As String, filenamePrefix As String, targetExtension As String, charset As String)
    Dim file As Object
    Dim logFiles As Collection
    Dim newFileName As String
    Dim fileContent As String
    Dim newFileContent As String

    ' フォルダ内のファイルを取得
    Set logFiles = ExtractFileFromFolder(inputFolderPath, targetExtension)

    ' 取得したファイルに対して処理を実行
    For Each file In logFiles
        ' ファイルを読み込む
        fileContent = ReadFileContent(file.Path, charset)

        ' 正規表現置換処理
        newFileContent = RegexReplace(fileContent, "^(?=\d)(\d{4})-(\d{2})-(\d{2})\b", "$1/$2/$3") ' YYYY-MM-DD を YYYY/MM/DD に変換
        newFileContent = RegexReplace(newFileContent, "^(?!\d{4}/\d{2}/\d{2}).*$", "") ' 行頭が日付以外の行を削除
        newFileContent = RegexReplace(newFileContent, "^\n", "") ' 空行（行頭に改行文字がある行）を削除

        ' 新しいファイル名を作成
        newFileName = RemovePeriod(file.Name)
        newFileName = inputFolderPath & "\" & filenamePrefix & newFileName & "." & targetExtension

        ' 作成ファイルを出力
        WriteFileContent newFileName, newFileContent, charset
    Next file
End Sub

' フォルダ内の指定拡張子のファイルを取得
Function ExtractFileFromFolder(inputFolderPath As String, targetExtension As String) As Collection
    Dim file As Object
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim logFiles As Collection: Set logFiles = New Collection ' .logファイルを格納するコレクションを初期化
    Dim inputFolder As Object: Set inputFolder = fso.GetFolder(inputFolderPath) ' 入力フォルダを取得

    For Each file In inputFolder.Files
        ' 指定した拡張子のファイルを収集
        If LCase(fso.GetExtensionName(file.Name)) = targetExtension Then
            logFiles.Add file
        End If
    Next file
    Set ExtractFileFromFolder = logFiles
End Function

Function RemovePeriod(fileName As String) As String
    Dim newName As String
    Dim originalExtension As String
    Dim periodPosition As Integer
    
    periodPosition = InStrRev(fileName, ".") ' 拡張子の位置を取得
    originalExtension = Mid(fileName, periodPosition) ' 拡張子を取得
    
    ' "log" を削除した部分を取得
    newName = Left(fileName, periodPosition - 1)
    newName = Replace(newName, "log", "")
    
    newName = newName & originalExtension ' 新しいファイル名を生成
    
    RemovePeriod = newName
End Function

' ファイルの内容を読み込む関数
Function ReadFileContent(filePath As String, charset as String) As String
    Dim stream As Object
    Dim content As String
    
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' 2 = テキストモードで読み込み
    stream.Charset = charset
    stream.Open
    stream.LoadFromFile filePath
    content = stream.ReadText(-1) ' -1 = 読込のみ
    stream.Close
    
    Set stream = Nothing
    
    ReadFileContent = content
End Function

' 指定文字列から指定正規表現に一致する文字列を指定文字に置換する
Function RegexReplace(inputStr As String, pattern As String, replaceString As String) As String
    Dim regEx As Object: Set regEx = CreateObject("VBScript.RegExp") ' 正規表現オブジェクト
    Dim outputStr As String
    
    With regEx
        .Global = True
        .MultiLine = True ' 行ごとにマッチ
        .Pattern = pattern
    End With
    
    outputStr = regEx.Replace(inputStr, replaceString) ' 置換処理

    RegexReplace = outputStr
End Function

' ファイル名とコンテンツを組み合わせて出力
Sub WriteFileContent(filePath As String, content As String, charset as String)
    Dim stream As Object
    
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2 ' 2 = Text
    stream.Charset = charset
    stream.Open
    stream.WriteText content
    stream.SaveToFile filePath, 2 ' 2 = 上書きモード
    stream.Close
    
    Set stream = Nothing
End Sub

' 指定エクセルの指定カラムの2行目から最終行までを読み込み、辞書を生成
Function CreateDictFromColumn(excelPath As String, column As Integer) As Object
    Dim xlApp As Object
    Dim xlWorkbook As Object
    Dim xlSheet As Object
    Dim lastRow As Long
    Dim dict As Object
    Dim key As String
    Dim value As String
    Dim i As Long
    
    ' 新しい辞書を作成する
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Excelアプリケーションを開く
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = False
    
    ' Excelファイルを開く
    Set xlWorkbook = xlApp.Workbooks.Open(excelPath)
    ' 最初のシートを取得
    Set xlSheet = xlWorkbook.Sheets(1)
    
    ' 指定された列の最終行を取得
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, column).End(-4162).Row
    
    ' シートからデータを読み込み、辞書に追加する
    For i = 2 To lastRow ' 2行目から開始
        key = xlSheet.Cells(i, column).Value
        If Not dict.exists(key) Then
            ' すでに存在しない場合のみ追加
            dict.Add key, ""
        End If
    Next i
    
    ' Excelを閉じる
    xlWorkbook.Close False
    xlApp.Quit
    
    ' オブジェクトの解放
    Set xlSheet = Nothing
    Set xlWorkbook = Nothing
    Set xlApp = Nothing
    
    ' 作成した辞書を返す
    Set CreateDictFromColumn = dict
End Function

' 指定エクセルの指定カラムの2行目から最終行までを読み込み、最初の文字のみを取得した辞書を生成
Function CreateFirstCharDictFromExcel(ByVal excelFilePath As String, ByVal column As Integer) As Object
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim lastRow As Long
    Dim i As Long
    Dim key As String
    Dim dict As Object
    
    ' 辞書を作成
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Excelアプリケーションを作成
    Set xlApp = CreateObject("Excel.Application")
    
    ' Excelファイルを開く
    Set xlBook = xlApp.Workbooks.Open(excelFilePath)
    
    ' シートを選択
    Set xlSheet = xlBook.Sheets(1) ' 1番目のシートを選択
    
    ' 指定列の最終行を取得
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, column).End(-4162).Row ' xlUpの-4162
    
    ' エクセルの指定列から文字列の最初を辞書のkeyに追加
    For i = 2 To lastRow ' 2行目から最終行までループ
        key = Left(xlSheet.Cells(i, column).Value, 1) ' 文字列の最初の文字をキーにする
        If Not dict.Exists(key) Then ' キーがまだ辞書に存在しない場合のみ追加
            dict.Add key, ""
        End If
    Next i
    
    ' Excelファイルを閉じる
    xlBook.Close False
    
    ' Excelアプリケーションを終了
    xlApp.Quit
    
    ' 使用したExcelオブジェクトを解放
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ' 作成した辞書を返す
    Set CreateFirstCharDictFromExcel = dict
End Function

' 指定配列の指定カラム番目の要素を詰める(引数は複数指定可)
Function RemoveColumnsFromArray(inputArr() As String, ParamArray columns() As Variant) As String()
    Dim outputArr() As String
    Dim i As Integer
    Dim j As Integer
    Dim index As Integer
    
    ' 出力配列のサイズを設定
    ReDim outputArr(LBound(inputArr) To UBound(inputArr) - UBound(columns))
    
    ' 出力配列のインデックスを設定
    index = LBound(outputArr)
    
    ' 入力配列から指定されたカラムを削除して新しい配列を作成
    For i = LBound(inputArr) To UBound(inputArr)
        Dim isToRemove As Boolean
        isToRemove = False
        ' 削除対象のカラムかどうかをチェックする
        For j = LBound(columns) To UBound(columns)
            If i = columns(j) Then
                isToRemove = True
                Exit For
            End If
        Next j
        ' 削除対象でない場合、要素を出力配列にコピーする
        If Not isToRemove Then
            outputArr(index) = inputArr(i)
            index = index + 1
        End If
    Next i
    
    ' 出力配列を返す
    RemoveColumnsFromArray = outputArr
End Function

Function RemoveAfterParen(inputStr As String) As String
    Dim parenIndex As Integer
    
    ' 最初の '(' を検索する
    parenIndex = InStr(inputStr, "(")
    
    ' '(' が見つかった場合
    If parenIndex > 0 Then
        ' '(' 以降の部分を削除して残りを返す
        RemoveAfterParen = Left(inputStr, parenIndex - 1)
    End If
    ' '(' が見つからない場合は、元の文字列をそのまま返す
    RemoveAfterParen = inputStr
End Function

' UTF-8のCSVを読み取り、一行ずつ配列に読み込む
Function ConvCSVToArray(ByVal filePath As String) As Variant
    Dim Stream As Object
    Dim fileContent As String
    
    ' ADODB.Streamオブジェクトを作成し、設定する
    Set Stream = CreateObject("ADODB.Stream")
    With Stream
        .Charset = "UTF-8"      ' 文字セットをUTF-8に設定する
        .Open                       ' ストリームを開く
        .LoadFromFile filePath     ' ファイルを読み込む
        fileContent = .ReadText    ' テキストを読み込んで変数fileContentに格納する
        .Close                      ' ストリームを閉じる
    End With
    
    ' 改行文字(vbLf)で文字列を分割し、配列に格納して返す
    ConvCSVToArray = Split(fileContent, vbLf)
End Function

Sub AppendToFile(outputFilePath As String, appendedStr As String)
    Dim stream As Object
    
    ' ADODB.Streamオブジェクトを作成する
    Set stream = CreateObject("ADODB.Stream")
    
    ' ストリームをUTF-8で初期化し、追記モードで開く
    stream.Type = 2 ' テキストモード
    stream.Charset = "UTF-8" ' UTF-8エンコーディング
    stream.Open
    
    ' ファイルを読み込んでストリームにロードする
    stream.LoadFromFile outputFilePath
    
    ' ストリームの位置をファイルの末尾に設定する
    stream.Position = stream.Size
    
    ' テキストをUTF-8で書き込む（追記）
    stream.WriteText appendedStr, 1 ' 追記モード
    
    ' ストリームをファイルに保存して閉じる
    stream.SaveToFile outputFilePath, 2 ' 上書き保存
    stream.Close
End Sub

フォルダを選択するダイアログを表示する関数
この関数はユーザーにフォルダ選択ダイアログを表示し、選択されたフォルダのパスを返します。

Function SelectFolder() As String
    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show = -1 Then
            folderPath = .SelectedItems(1)
            SelectFolder = folderPath
        Else
            MsgBox "フォルダが選択されませんでした。"
            SelectFolder = ""
        End If
    End With
End Function

VBAでは直接ファイルから文字コードを自動的に判断する標準機能は提供されていません。ただし、外部ライブラリやツールを利用する方法もありますが、それを使わずに一部の基本的な判定（例えばBOM（Byte Order Mark）の有無によるUTF-8の判断）を行うことは可能です。ここでは、ファイルがUTF-8（BOMあり）であれば0、それ以外（ここではSJISと仮定）であれば1を返す基本的な例を紹介します。

' 指定ファイルパスの文字コードからCharsetを取得
Function getCharsetMode(filePath As String) As Integer
    Dim fileNo As Integer
    Dim firstBytes As String
    Dim charsetMode As Integer
    
    fileNo = FreeFile()
    Open filePath For Binary As #fileNo
    
    ' 最初の3バイトを読み込む
    firstBytes = String(3, 0)
    Get #fileNo, , firstBytes
    Close #fileNo
    
    ' UTF-8のBOMはEF BB BF
    If AscB(MidB(firstBytes, 1, 1)) = &HEF And _
       AscB(MidB(firstBytes, 2, 1)) = &HBB And _
       AscB(MidB(firstBytes, 3, 1)) = &HBF Then
        charsetMode = 0  ' UTF-8 (BOMあり)
    Else
        charsetMode = 1  ' SJIS（仮定）
    End If
    
    getCharsetMode = charsetMode
End Function

与えられた配列の各要素を空白で区切って一つの文字列に結合する関数を作成できます。以下はその例です：

' 配列を空白区切りの文字列に変換する
Function JoinArrayToStr(arr() As String) As String
    Dim resultStr As String
    Dim i As Integer
    
    ' 結果を初期化
    resultStr = ""
    
    ' 配列の各要素を空白で区切って結合する
    For i = LBound(arr) To UBound(arr)
        If i = LBound(arr) Then
            ' 最初の要素の場合は空白を追加せずに要素を追加する
            resultStr = arr(i)
        Else
            ' 2番目以降の要素の場合は空白を追加してから要素を追加する
            resultStr = resultStr & " " & arr(i)
        End If
    Next i
    
    ' 結果を返す
    JoinArrayToStr = resultStr
End Function

' 文字列が()を含むか確認する
Function HasParentheses(inputString As String) As Boolean
    ' 文字列に左括弧と右括弧が含まれているかを確認する
    HasParentheses = InStr(inputString, "(") > 0 And InStr(inputString, ")") > 0
End Function

' ()でくくられた文字列部分を削除する
Function RemoveParentheses(inputString As String) As String
    Dim openParenIndex As Integer
    Dim closeParenIndex As Integer
    Dim resultString As String
    
    ' 文字列に括弧が含まれているかを確認する
    If HasParentheses(inputString) Then
        ' 左括弧のインデックスを検索する
        openParenIndex = InStr(inputString, "(")
        
        ' 右括弧のインデックスを検索する
        closeParenIndex = InStr(openParenIndex, inputString, ")")
        
        ' 括弧とその内側の文字列を削除する
        resultString = Left(inputString, openParenIndex - 1) & Mid(inputString, closeParenIndex + 1)
    Else
        ' 括弧が含まれていない場合は、元の文字列を返す
        resultString = inputString
    End If
    
    RemoveParentheses = resultString
End Function

' inputStrが"http"から始まる場合にTrueを返す
Function IsStartHttp(inputStr As String) As Boolean
    IsStartHttp = Left(inputStr, 4) = "http"
End Function

' inputStrの後ろから二つ目の'/'から後ろまでの文字列を'_'区切りにして返す
Function ExtractString(inputStr As String) As String
    Dim segments() As String
    Dim outputStr As String
    Dim i As Integer

    ' 最後の文字がスラッシュの場合は削除
    If Right(inputStr, 1) = "/" Then
        inputStr = Left(inputStr, Len(inputStr) - 1)
    End If
    
    ' '/' で文字列を分割して配列に格納する
    segments = Split(inputStr, "/")
    
    ' 配列の後ろから2番目の要素から最後までを抜き取る
    outputStr = ""
    For i = UBound(segments) - 1 To UBound(segments)
        If outputStr <> "" Then
            outputStr = outputStr & "_"
        End If
        outputStr = outputStr & segments(i)
    Next i
    
    ' 結果を返す
    ExtractAndJoin = outputStr
End Function

' 開始時刻と終了時刻を引数として受け取り、その差を計算して実行時間を求めます
Function CalculateExecutionTime(startTime As Double, endTime As Double) As String
    Dim executionTime As Double
    Dim hours As Integer
    Dim minutes As Integer
    
    ' 実行時間を計算する（秒単位）
    executionTime = endTime - startTime
    
    ' 実行時間を時と分に変換する
    hours = Int(executionTime / 3600)
    minutes = Int((executionTime - (hours * 3600)) / 60)
    
    ' 実行時間を文字列形式で返す（HH:MM 形式）
    CalculateExecutionTime = Format(hours, "00") & ":" & Format(minutes, "00")
End Function

Function HasFrontParen(inputStr As String) As Boolean
    ' '(' が存在し、かつ ')' が存在しない場合に True を返す
    If InStr(inputStr, "(") > 0 And InStr(inputStr, ")") = 0 Then
        HasFrontParen = True
    Else
        HasFrontParen = False
    End If
End Function

カレントディレクトリの.txtから.logを作成

@echo off
for %%f in (*.txt) do (
    set filename=%%~nf
    echo Processing %%f...
    echo Creating %%filename%.log...
    (
        for /F "tokens=*" %%l in (%%f) do (
            echo %%l>>"%%filename%.log"
        )
    )
)
echo Process completed.
pause