VBAを使った簡単／無料の書類トレイを作ってみた

はじめに

コロナ渦でテレワークの急速な普及による働き方の変化により、勤め先でも書類が紙承認→電子承認へ切り替わってきています。しかし、書類のやり取りはメールでの送受信となり、メール数が増え非効率。サーバー上で書類のやり取りをする電子トレイのソフトウェアは不景気のため新規購入できず。
そんな悩みをVBAで解決できたので、備忘録も兼ねて書きます。

概要

エクセルVBAを使ってユーザーフォームを作り、書類の受け箱（トライ）を電子トレイ化

考え方

（前準備）サーバーに各個人の電子トレイ（フォルダ）を準備／各人に電子トレイVBAの配布
①VBAでフォルダにアクセスし、フォルダ内のファイル数やファイル名を取得しGUIに表示
②ユーザーフォームからファイルを選択して、開いて承認処理
③ユーザーフォームで送付先電子トレイ（フォルダ）と送付するファイルを選択して、ファイルを送付先電子トレイに移動

簡単に言うと、VBAの個人フォルダにアクセスし、ファイルを開き処理して、他人のフォルダにファイルを移動する。

コード

今回作成したコードで、
　①フォルダにアクセスし、フォルダ内のファイル数やファイル名を取得する
　②ファイルを選択して、開く
　③送付先電子トレイ（フォルダ）と送付するファイルを選択して、ファイルを送付先電子トレイに移動
のコードを紹介する

①フォルダにアクセスし、フォルダ内のファイル数やファイル名を取得する

Sub file_name_get()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


    Dim buf As String, cnt As Long, num As Integer
    Dim Path As String

    Path = ThisWorkbook.Path & Range("B2") '←電子トレイのPATH

    buf = Dir(Path & "*.*")
    cnt = 3
    Do While buf <> ""                    
        cnt = cnt + 1
        Cells(cnt, 2) = buf                 '←電子トレイのファイル名を取得し、対象のセルに記録
        buf = Dir()
    Loop

    num = Range("B3").Value                 '←電子トレイのファイル数を取得し、対象のセルに記録

End Sub

②ファイルを選択して、開く

※ユーザーフォームでボタン操作およびリストボックスで選択を前提

Private Sub btn_open_Click()
    Dim operation As String, file_name As String
    Dim file_name_path As String
    Dim myMsg As String, myTitle As String

　　'↓電子トレイのファイル名の入ったリストボックスからファイルを選択する
    With ListBox1                 
        If .ListIndex = -1 Then
            myMsg = "ファイルを選択してください。"
            myTitle = "ファイル選択エラー"
            MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
        ElseIf .Value = "" Then
            myMsg = "ファイルを選択してください。"
            myTitle = "ファイル選択エラー"
            MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
        Else
            file_name = .Value
            file_name_path = ThisWorkbook.Path & Range("B2") & file_name　'←送り先電子トレイPATH
            CreateObject("Shell.Application").ShellExecute file_name_path
        End If
    End With

End Sub

③送付先電子トレイ（フォルダ）と送付するファイルを選択して、ファイルを送付先電子トレイに移動

※ユーザーフォームでボタン操作およびリストボックスで選択を前提

Private Sub btn_reply_Click()
    Dim fso As Object
    Dim operation As String, file_name As String, sellect_name As String
    Dim i As Integer
    Dim myMsg As String, myTitle As String
    Dim myBtn As Integer
    Dim current_path As String, sellect_path As String

    Set fso = CreateObject("Scripting.FileSystemObject")

    '↓電子トレイのファイル名の入ったリストボックス1からファイルを選択する
    '↓送付する電子トレイ名の入ったリストボックス2からファイルを選択する
    If ListBox1.ListIndex = -1 Then
        myMsg = "ファイルを選択してください。"
        myTitle = "ファイル選択エラー"
        MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
    ElseIf ListBox1.Value = "" Then
            myMsg = "ファイルを選択してください。"
            myTitle = "ファイル選択エラー"
            MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
    ElseIf ListBox2.ListIndex = -1 Then
        myMsg = "送付先を選択してください。"
        myTitle = "送付先選択エラー"
        MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
    ElseIf ListBox2.Value = "" Then
        myMsg = "送付先を選択してください。"
        myTitle = "送付先選択エラー"
        MsgBox myMsg, vbOKOnly + vbExclamation, myTitle
    Else
        file_name = ListBox1.Value
        sellect_name = ListBox2.Value

        myMsg = file_name & "を" & sellect_name & "さんへ送付してもよいですか？"
        myTitle = "ファイル確認"
        myBtn = MsgBox(myMsg, vbOKCancel + vbExclamation, myTitle)


        If myBtn = vbOK Then
            current_path = ThisWorkbook.Path & Range("B2") & file_name
            '↓送付する電子トレイ名のPATHを保存してあるCellから検索する
            For i = 2 To Cells(Rows.Count, 4).End(xlUp).Row
                If Cells(i, 4) = sellect_name Then
                    sellect_path = ThisWorkbook.Path & Cells(i, 5)
                End If
            Next
            '↓送付する電子トレイへファイルを移動
            fso.Movefile current_path, sellect_path
        End If
    End If

    Set fso = Nothing

End Sub

今後

セキュリティを考慮して、電子トレイを開くときのパスワードなどを追加検討中