ファイル名＆更新日付を撮影日付（更新日付）で変換

・ファイル名を更新日付で変換.vbs

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'ファイル名を更新日付で変換
'  arg1 : (必須)コピー元パス(ファイル or フォルダ)
'  arg2 :       コピー先パス(〃)
'
'  コピー元からコピー先へファイルをコピーし、
'  撮影日付(更新日付)でリネームする。
'  ※フォルダ指定の場合は指定直下のファイルのみが対象
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'履歴
'   1.0.0       新規作成
'   1.0.1       画像形式で撮影日時があればそちらを優先させる
'   1.0.2       撮影日時がうまく取れていなさそうならファイル自体の更新日付とする、一番最初に例外出る問題修正、引数指定が相対パスにもそこそこ(暫定)対応
'   1.0.3       (2018/11/23)エクスプローラのドラッグに対応
'   1.0.4       (2023/10/29)ffmpegを用いてiPhoneからの撮影日を判定材料にできるよう対応
'                           物理コピーとリネームのモードを切り分けできるよう対応
'                           同名リネーム時に何もしないよう対応
'                           更新日付もファイル名に合わせれるよう対応
'                           ブラッシュアップ
'   1.0.5       (2023/11/01)heicも対象にするよう対応、ffmpegのcreation_timeにタイムゾーンを反映するよう対応
'   1.0.6       (2023/11/29)処理を画像と動画に分離(画像でffmpegしても得るものがないため)、ffmpegのタイムゾーン判定基準(簡易)が間違ってたの修正、PNG解析して"eXIf"からも作成日付をとれるよう対応
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'<メモ>
'・CreateObject("Wia.ImageFile") ExifDTOrig を使用する方法
'  →ファイル先頭の解析した値って感じではなく、持ってる値取ってきただけって感じ
'
'
'
'
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Const VERSION = "1.0.6"

'コピーフラグ
'  1:物理コピー
'  2:リネーム
Const COPY_FLAG = 2

'更新日付更新するか（変更する一番古い日付と同じ）
'  True :変更する
'  False:しない
Const EDIT_DATE_FLAG = True





'時差(分)
Dim m_TimeZoneDate



'メイン処理
Call Main
WScript.Quit


'OpenTextFile-IOMode
Const ForReading = 1
Const ForWriting = 2
Const ForAppending = 8

'OpenTextFile-Format
Const TristateFalse = 0
Const TristateTrue = -1
Const TristateUseDefault = -2


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     メイン処理
'//
'//  引数
'//     なし
'//
'//  戻り値
'//     なし
'//
'//////////////////////////////////////////////////////////////////////////////
Sub Main()
    Dim oFsoF       '<FileSystemObject>
    Dim sSrcDir     'コピー元フォルダパス（末尾「\」なし）
    Dim sDesDir     'コピー先フォルダパス（末尾「\」なし）
    Dim lNum        '数（コマンドライン引数の数）
    Dim iCnt1       'ループ用
    Dim sTmp        '作業用
    Dim oFsoS       '<ShellFolderItem> In <Shell.Application.Namespace().Items>
    Dim oWs         '<WScript.Shell>
    Dim bFfmpegVer  '"ffmpeg"が使えるかどうか（True:使える）
    Dim oExe        '<WScript.Shell> <Exec>
    Dim oSa         '<Shell.Application>
    Dim sMsg        '処理結果格納変数




    sMsg = ""
    
    
    '■引数取得/チェック■
    '引数からSrc/Des を取得する
    lNum = GetArg(sSrcDir, sDesDir)
    
    '引数判定[１]
    Select Case lNum
    Case 1
        'ドラッグなどのケース、出力先は固定値とする。
        sDesDir = sSrcDir & "_Des"
    Case 2
        'bat起動などを想定(2フォルダドラッグは検知できないので無視)
    Case Else
        WScript.echo "[中断]" & lNum & "件：指定が不正！" & vbCrLf _
                   & "・[1]コピー元" & vbCrLf _
                   & "・[1]コピー元, [2]コピー先" & vbCrLf _
                   & "を指定してください。"
        Exit Sub
    End Select
    
    
    Set oFsoF = CreateObject("Scripting.FileSystemObject")
    
    
    '引数判定[２]
    If Not oFsoF.FolderExists(sSrcDir) Then
        '指定のフォルダが存在しない場合は中断
        WScript.echo "[中断]コピー元「" & sSrcDir & "」フォルダが存在しない"
        Set oFsoF = Nothing
        Exit Sub
    End If
    
    
    '■実処理１：出力先の調整■
    If COPY_FLAG = 1 Then
        '物理的にDesを複製
        'コピー先を事前に削除する(強制)
        If oFsoF.FolderExists(sDesDir) Then
            Call oFsoF.DeleteFolder(sDesDir, True)
        End If
        '一度コピー先へコピー
        Call oFsoF.CopyFolder(sSrcDir, sDesDir, True)
        
    ElseIf COPY_FLAG = 2 Then
        'Src側をリネーム
        sDesDir = sSrcDir
    End If
    
    
    '■実処理１：日付切替■
    'コピー先のファイルを一式取得   ※TODO:配下フォルダまでは見ない
    Set oSa = CreateObject("Shell.Application")
    Set oWs = CreateObject("WScript.Shell")
    
    
    
    'ffmpeg確認
    bFfmpegVer = GetFfmpegVer(oWs)

    'タイムゾーンの時差取得
    m_TimeZoneDate = GetTimeZoneDate()

    'コピー先フォルダをループし、ファイル名を更新日付などに変更する
    For Each oFsoS In oSa.Namespace(sDesDir).Items
        Dim sTmpNameTail    'ファイル名(拡張子付き)
        Dim sTmpFullName    'ファイル名フルパス(拡張子付き)
        Dim sDateTime       '実際の日付(更新日付/撮影日付)
        Dim sTmpTail        '拡張子
        Dim sTmpTailLow     '拡張子(判定用の小文字)
        
        
        With oFsoS
            sTmpTail = oFsoF.GetextensionName(.Name)
            sTmpTailLow = LCase(sTmpTail)
            '拡張子で行う処理を変更
            Select Case sTmpTailLow
            Case "png"
                '画像系統は 「撮影日付」「更新日付」「Apple撮影日付」から古いものを優先とする ※WhenTakenはタイムゾーンもプラスする
                sDateTime = .ModifyDate
                If .ExtendedProperty("WhenTaken") <> "" Then
                    'EXIF？から撮影日を取得
                    sTmp = DateAdd("n", m_TimeZoneDate, .ExtendedProperty("WhenTaken"))
                    If sTmp < sDateTime Then
                        sDateTime = sTmp
                    End If
                End If
                sTmp = GetExifCreateDateInPNG(.Path)
                If sTmp <> "" Then
                    sTmp = CDate(sTmp)
                    If sTmp < sDateTime Then
                        sDateTime = sTmp
                    End If
                End If
                
                
            Case "jpg", "jpeg", "gif", "png", "bmp", "bitmap", "heic"
                '画像系統は 「撮影日付」「更新日付」「Apple撮影日付」から古いものを優先とする ※WhenTakenはタイムゾーンもプラスする
                sDateTime = .ModifyDate
                If .ExtendedProperty("WhenTaken") <> "" Then
                    'EXIF？から撮影日を取得
                    sTmp = DateAdd("n", m_TimeZoneDate, .ExtendedProperty("WhenTaken"))
                    If sTmp < sDateTime Then
                        sDateTime = sTmp
                    End If
                End If
            Case "mov", "avi", "mp4", "mp3", "flv"
                '画像系統は 「撮影日付」「更新日付」「Apple撮影日付」から古いものを優先とする ※WhenTakenはタイムゾーンもプラスする
                sDateTime = .ModifyDate
                If .ExtendedProperty("WhenTaken") <> "" Then
                    'EXIF？から撮影日を取得
                    sTmp = DateAdd("n", m_TimeZoneDate, .ExtendedProperty("WhenTaken"))
                    If sTmp < sDateTime Then
                        sDateTime = sTmp
                    End If
                End If
                If (bFfmpegVer) Then
                    'ffmpegから作成日時(撮影日時)取得し判定
                    sTmp = GetFfmpegInfo(oWs, .Path)
                    If sTmp < sDateTime Then
                        sDateTime = sTmp
                    End If
                End If
            Case Else
                'その他は更新日付を優先とする
                sDateTime = .ModifyDate
            End Select
            
            '変換後のファイル名取得
            sTmpNameTail = GetDateNum(sDateTime) & "-" & GetTimeNum(sDateTime) & "." & sTmpTail
            sTmpFullName = sDesDir & "\" & sTmpNameTail
            
            '同名ファイルとなった場合の対処(あったら連番を振っていく※元々のはそのまま)
            For iCnt1 = 2 To 999
                If oFsoF.FileExists(sTmpFullName) Then
                    If (.Name = sTmpNameTail) Then
                        'リネーム前後で変化がない場合は現状維持(更新日付は見る)
                        Call EdtModifyDate(oFsoS, sDateTime)
                        Exit For
                    Else
                        sTmpNameTail = GetDateNum(sDateTime) & "-" & GetTimeNum(sDateTime) & "_" & Right("00" & iCnt1, 3) & "." & sTmpTail
                        sTmpFullName = sDesDir & "\" & sTmpNameTail
                    End If
                Else
                    'ファイル名(/更新日付)変更
                    .Name = sTmpNameTail
                    Call EdtModifyDate(oFsoS, sDateTime)
                    Exit For
                End If
            Next
            If (iCnt1 = 1000) Then
                'リネームできなければそのまま終わっちゃう。
                sMsg = sMsg & "[" & .Name & "]リネームできず" & vbCrLf
            End If
'            WScript.echo .name  & " = " & sTmpNameTail & vbcrlf & _
'                         "" & ( oSa.Namespace(sDesDir).ParseName(.name).ExtendedProperty("size")) & vbcrlf & _
'                         (.name = sTmpNameTail)
        End With
    Next

    sMsg = sMsg & vbCrLf & oSa.Namespace(sDesDir).Items.Count & "ファイル処理完了"


    Set oWs = Nothing
    Set oSa = Nothing
    Set oFsoF = Nothing
    
    
    '結果を画面だけに…
    WScript.echo sMsg

End Sub


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     コマンドライン引数の情報取得
'//
'//  引数
'//     sSrcDir O   コピー元フォルダパス（末尾「\」なし）
'//     sDesDir O   コピー先フォルダパス（末尾「\」なし） ※指定がない場合は空白
'//
'//  戻り値
'//     コマンドライン引数で指定した数
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetArg(ByRef sSrcDir, ByRef sDesDir)
    Dim oParm
    Dim oFso        '<Scripting.FileSystemObject>
    Dim lCnt1
    Dim sArgArr()

    '初期化
    Set oParm = WScript.Arguments
    GetArg = oParm.Count
    
'WScript.echo GetArg
    '判定
    If (0 < GetArg) Then
        Set oFso = CreateObject("Scripting.FileSystemObject")
        ReDim sArgArr(GetArg - 1)
        '指定のフォルダ名を設定
        With oFso
            For lCnt1 = 0 To GetArg - 1
                If .FileExists(oParm(lCnt1)) Then
                    'ファイルならそこのフォルダ名を取得
                    sArgArr(lCnt1) = .getParentFolderName(oParm(lCnt1))
'WScript.echo "[" & lCnt1 & "]  " & sArgArr(lCnt1)
'                    exit for
                ElseIf .FolderExists(oParm(lCnt1)) Then
                    'フォルダ指定ならそこのフォルダ名を取得
                    sArgArr(lCnt1) = .GetAbsolutePathName(oParm(lCnt1))
'WScript.echo "[" & lCnt1 & "]  " & sArgArr(lCnt1)
'                    exit for
                Else
                    'TODO:フォルダが既存から存在しない場合でも一応入れる、相対パス考慮で
                    sArgArr(lCnt1) = .BuildPath(.getParentFolderName(WScript.ScriptFullName), oParm(lCnt1))
                End If
            Next
        End With
        
        '引数にセット
        Select Case GetArg
        Case 1:
            'コピー元だけ
            sSrcDir = sArgArr(0)
            sDesDir = ""
        Case 2:
            'コピー元/コピー先をセット
            sSrcDir = sArgArr(0)
            sDesDir = sArgArr(1)
        Case Else:
            '指定より多い場合は最初の二つのみセット
            sSrcDir = sArgArr(0)
            sDesDir = sArgArr(1)
        End Select
        
        '後始末
        Set oFso = Nothing
        
    Else
        '引数ない場合はしゃーない
        sSrcDir = ""
        sDesDir = ""
    End If
    
    '後始末
    Set oParm = Nothing
    
    '正常終了
    Exit Function
End Function


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     (共通)実際の更新日付と変更予定の更新日時に差異がある場合は更新日付を再設定する
'//
'//  引数
'//     oFsoS        I/O <ShellFolderItem> In <Shell.Application.Namespace().Items>
'//     sDateTime    I   実際の日付(更新日付/撮影日付)
'//
'//  戻り値
'//     なし
'//
'//////////////////////////////////////////////////////////////////////////////
Public Sub EdtModifyDate(oFsoS, sDateTime)
    With oFsoS
        If EDIT_DATE_FLAG Then
            If .ModifyDate <> sDateTime Then
                .ModifyDate = sDateTime
            End If
        End If
    End With
End Sub


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     ffmpegが使えるか確認
'//
'//  引数
'//     oWs I   <WScript.Shell>
'//
'//  戻り値
'//     true  : ffmpegが使える
'//     false : ffmpegが使えない
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetFfmpegVer(oWs)
    'Dim sLine
    Dim oRet
    
    
    If oWs Is Nothing Then
        Set oWs = CreateObject("WScript.Shell")
    End If
    
    Set oRet = oWs.Exec("cmd /c ffmpeg -version")
    With oRet
        'cmd結果待ち
        Do While .Status = 0
          WScript.Sleep 100
        Loop
        
        GetFfmpegVer = (.ExitCode = 0)
    End With
End Function


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     ffmpegの情報を取得する
'//
'//  引数
'//     oWs     I   <WScript.Shell>
'//     sPath   I   確認対象のファイルパス（フルパス）
'//
'//  戻り値
'//     ffmpegから取ってきた古い日付のDate型日付（何かしら動画ファイルの場合に取得）、
'//     失敗している場合は Now が返る
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetFfmpegInfo(oWs, sPath)
    Dim sLine           '作業用(取得行)
'    Dim sTmp: sTmp = "" '作業用
    Dim arTmp           '作業用
    Dim oExec           'cmd結果
    Dim dOldestDate     '一番若い<Date型>
    Dim dTmpDate        '作業用<Date型>
    Dim bTimeZoneFlg    'タイムゾーン補正が必要かどうか
    
    
    'NOTE.cmdのウィンドウはチラチラ出ちゃうのは我慢する（Runで隠せるが標準出力が取れない問題あるし(結果をファイルに落とし込めば行けるが、パフォーマンス悪いので却下)）
    Set oExec = oWs.Exec("cmd /c ffmpeg -i """ & sPath & """ 2>&1 | find ""creation"" /i")
    With oExec
        'cmd結果待ち
        Do While .Status = 0
          WScript.Sleep 100
        Loop
        
        dOldestDate = Now   '※調べるファイルは現在日時より古い前提（システム日付に問題がなければ…）
        
        '結果読み込んで古い日付を取得
        With .StdOut
            Do While .AtEndOfStream = False
'    creation_time                   : 2023-10-11T13:26:40.000000Z
'    com.apple.quicktime.creationdate: 2023-09-27T18:20:45+0900
'    →といった内容の書式のフォーマットを YYYY/MM/DD HH:MM:SS に変更する
                sLine = .ReadLine
                bTimeZoneFlg = (0 < InStr(sLine, "creation_time"))
                '日付部分のみ抽出
                arTmp = Split(sLine, ":", 2)
                sLine = Trim(arTmp(1))
                sLine = Mid(sLine, 1, 19)
                sLine = Replace(sLine, "-", "/")
                sLine = Replace(sLine, "T", " ")

                dTmpDate = CDate(sLine)
                If bTimeZoneFlg Then
                    dTmpDate = DateAdd("n", m_TimeZoneDate, dTmpDate)
                End If
                If (dTmpDate < dOldestDate) Then
                    dOldestDate = dTmpDate
                End If
'sTmp = sTmp & Mid(sPath, InStrRev(sPath, "\")+1, 255) & " : " & dTmpDate & vbCrLf
            Loop
        End With
    End With
    Set oExec = Nothing
'WScript.echo sTmp

    
    GetFfmpegInfo = dOldestDate
End Function




'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     PNGのeXIf情報から日付取得
'//
'//  引数
'//     filepath    I   ファイルフルパス
'//
'//  戻り値
'//     失敗時:空文字
'//     成功時:日付文字列
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetExifCreateDateInPNG(ByVal filepath)
    Dim bBuf
    Dim iIdx1
    Dim iIdx1U
    Dim iLen
    Dim iIdx3
    Dim lLen
    Dim sTmp
    Dim sMsg


    'Call UseTextAscWBufferRead(bBuf, filepath, 65536)
    Call UseTextAscWBufferRead(bBuf, filepath, 2000)

    sTmp = BinToHexStr(bBuf, 0, 8)
    
    If sTmp <> "89504E470D0A1A0A" Then
        'PNG形式じゃない場合は失敗
        GetExifCreateDateInPNG = ""
        Exit Function
    End If
    'TODO:拡張子もチェックしてていいかも？


    '中身ループさせてeXIf情報を取得する
    iIdx1 = 8	'PNG形式
    iIdx1U = UBound(bBuf)
    lLen = 0
    Do While (iIdx1 < iIdx1U)
        'サイズ取得
        iLen = CLng("&H" & BinToHexStr(bBuf, iIdx1, 4))
        iIdx1 = iIdx1 + 4
        'チャンク
        sTmp = BinToAsciiStr(bBuf, iIdx1, 4)
        iIdx1 = iIdx1 + 4
        'データ＆CRC
        iIdx1 = iIdx1 + iLen + 4
        '確認用
        
        Select Case sTmp
        Case "eXIf", "IEND"
            Exit Do
        Case "IDAT"
            'NOTE.iPhoneではEXIF<IDATの定義っぽいので、これが来ても終わる。
            Exit Do
        End Select
    Loop

    If sTmp <> "eXIf" Then
        'お目当ての情報がなかったので終了
        GetExifCreateDateInPNG = ""
        Exit Function
    End If

    '日付形式を取得し変換する
    'TODO:位置は固定(フォーマットが見当たらなかったので…"eXIf"サイズは130(0x82)ぐらいかな？)
    sTmp = BinToAsciiStr(bBuf, iIdx1+92-iLen-4, 19)
    sTmp = Replace(sTmp, ":", "/", 1, 2)
    if IsDate(sTmp) Then
        GetExifCreateDateInPNG = sTmp
    Else
        GetExifCreateDateInPNG = ""
    End If

End Function




'http://moritora.seesaa.net/article/272696528.html
'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     bin読込
'//
'//  引数
'//     xxx
'//
'//  戻り値
'//     なし
'//
'//////////////////////////////////////////////////////////////////////////////
Sub UseTextAscWBufferRead(ByRef a(), ByVal filepath, ByVal lReadLen)
    Dim stream
    Set stream = CreateObject("ADODB.Stream")
    With stream
        Call .Open()
        .Type = 2 '2:adTypeText)
        .Charset = "UTF-16BE"
        Call .LoadFromFile(filepath)
        ReDim a(.Size - 1)
        Dim length
        length = lReadLen
        Dim j
        j = 0
        Dim remain
        remain = .Size \ 2
        Do While (remain > 0)
            If (remain < length) Then
                length = remain
            End If
            Dim buffer
            buffer = .ReadText(length)
            Dim i, n
            For i = 1 To length
                n = AscW(Mid(buffer, i, 1))
                a(j) = (n And &HFF00&) \ &H100
                a(j + 1) = n And &HFF
                j = j + 2
            Next
            remain = remain - length
        Loop
        If ((.Size And 1) = 1) Then
            .Position = .Size
            Call .WriteText(ChrW(0))
            .Position = .Size - 3
            a(UBound(a)) = (AscW(.ReadText(1)) And &HFF00&) \ &H100
        End If
        Call .Close()
    End With
End Sub




'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     年月日取得
'//
'//  引数
'//     日付(文字列可能)
'//
'//  戻り値
'//     yyyymmdd形式
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetDateNum(sDate)
    Dim dDate
    
    '日付形式に変換
    dDate = CDate(sDate)
    GetDateNum = Right("0000" & Year(dDate), 4) _
               & Right("00" & Month(dDate), 2) _
               & Right("00" & Day(dDate), 2)
    Exit Function
End Function


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     時間取得
'//
'//  引数
'//     日付(文字列可能)
'//
'//  戻り値
'//     hhmmss形式
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetTimeNum(sDate)
    Dim dTime
    
    '日付形式に変換
    dTime = CDate(sDate)
    GetTimeNum = Right("00" & Hour(dTime), 2) _
               & Right("00" & Minute(dTime), 2) _
               & Right("00" & Second(dTime), 2)
End Function

'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     タイムゾーンの時差取得
'//
'//  引数
'//     なし
'//
'//  戻り値
'//     時差(分っぽい)
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function GetTimeZoneDate()

    Dim oLocator        'WbemScripting
    Dim oService        'ConnectServer
    Dim oClassSet       'ExecQuery結果
    Dim oClass          'ループ用obj

    GetTimeZoneDate = 0

    Set oLocator = WScript.CreateObject("WbemScripting.SWbemLocator")
    Set oService = oLocator.ConnectServer
    Set oClassSet = oService.ExecQuery("Select Bias From Win32_TimeZone")

    '時差のみ取得
    For Each oClass In oClassSet
        GetTimeZoneDate = oClass.Bias
        Exit For
    Next

    '後始末
    Set oClassSet = Nothing
    Set oClass = Nothing
    Set oService = Nothing
    Set oLocator = Nothing

End Function



'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     byte配列からHEX文字列取得
'//
'//  引数
'//     bBuf        I   byte配列
'//     lStartIdx   I   開始インデックス(bBuf範囲内)
'//     lSize       I   取得byteサイズ
'//
'//  戻り値
'//     0埋め16進文字列(大文字)
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function BinToHexStr(bBuf(), ByVal lStartIdx, ByVal lSize)
    Dim sTmp
    Dim lIdx

    sTmp = ""
    lIdx = lStartIdx
    For lIdx = 0 To (lSize - 1)
        sTmp = sTmp & Right("00" & Hex(bBuf(lIdx + lStartIdx)), 2)
    Next

    BinToHexStr = sTmp
End Function


'//////////////////////////////////////////////////////////////////////////////
'//
'//  説明
'//     byte配列からASCII文字列取得
'//
'//  引数
'//     bBuf        I   byte配列
'//     lStartIdx   I   開始インデックス(bBuf範囲内)
'//     lSize       I   取得byteサイズ
'//
'//  戻り値
'//     ASCII文字列
'//
'//////////////////////////////////////////////////////////////////////////////
Public Function BinToAsciiStr(bBuf(), ByVal lStartIdx, ByVal lSize)
    Dim sTmp
    Dim lIdx

    sTmp = ""
    lIdx = lStartIdx
    For lIdx = 0 To (lSize - 1)
        sTmp = sTmp & Chr(bBuf(lIdx + lStartIdx))
    Next

    BinToAsciiStr = sTmp
End Function

[その他]
・動作保証できません。
・操作方法を間違えれば危険なものであるため、いかなる不利益も保証しません。