VSSより、指定したファイルを取得するマクロ

Option Explicit

'VSSのiniファイルの場所
Private SRCSAFE_INI As String
'VSS接続のユーザID
Private USER_ID As String
'VSS接続のパスワード
Private USER_PASSWORD As String
'VSS Root
Private VSS_ROOT As String
'ファイル出力先
Private OUTPUT_DIR As String

'ファイルオブジェクト
Private mobjFileSystem As FileSystemObject

'機能名：　VSSより、指定したファイルを取得するマクロ（パス入り）
'作成者：　SHSC
'作成日：　2006/01/13
'修正履歴：YYYY/MM/DD Name Content
'
'
Sub Macro1()
    On Error GoTo ErrorHandler
    Dim vssDB As New VSSDatabase
    Dim objItem As VSSItem
    Dim rowNumber As Integer
    Dim sheet As Worksheet
   
    Set mobjFileSystem = New FileSystemObject
    Set sheet = ThisWorkbook.Worksheets("RTM")

    '設定値取得
    Call GetSettingValues
   
    '行番号初期化
    rowNumber = 2
   
    'VSS接続
    vssDB.Open SRCSAFE_INI, USER_ID, USER_PASSWORD
   
    While sheet.Cells(rowNumber, 1) <> ""
        'CO対象かをチェック
        If sheet.Cells(rowNumber, 2) = "○" Then
            Set objItem = vssDB.VSSItem(VSS_ROOT & sheet.Cells(rowNumber,)
            'Call OutputVSSItem(objItem)
            'Call CheckOutVSSItem(objItem)
            Call CheckInVSSItem(objItem)
        End If
        rowNumber = rowNumber + 1
    Wend
   
    Set vssDB = Nothing
    Set mobjFileSystem = Nothing
   
    MsgBox "ファイル取得が完了しました。"
   
Exit Sub                                ' エラー処理ルーチンが実行されないように Sub を終了します。
ErrorHandler:                           ' エラー処理ルーチン。
    Select Case Err.Number              ' エラー番号を評価します。
        Case -2147166577                ' エラーです。
            MsgBox "[" & VSS_ROOT & sheet.Cells(rowNumber, & "] が見つかりません。"
            Resume Next                 ' エラーが発生した行から処理を再開します。
           
        Case Else
            Resume Next                 ' エラーが発生した行から処理を再開します。
    End Select
   
End Sub


'設定値を変数へ格納
Private Sub GetSettingValues()
    Dim sheet As Worksheet
   
    Set sheet = ThisWorkbook.Worksheets("設定")
   
    'srcsafe.iniの場所
    SRCSAFE_INI = sheet.Cells(3, 2)

    'VSS接続ユーザID
    USER_ID = sheet.Cells(4, 2)

    'VSS接続ユーザパスワード
    USER_PASSWORD = sheet.Cells(5, 2)

    'VSS Root
    VSS_ROOT = sheet.Cells(6, 2)
   
    'ファイル出力
    OUTPUT_DIR = sheet.Cells(7, 2)
   
End Sub


'指定フォルダへ最新バージョンのファイルを出力する処理
Private Sub OutputVSSItem(objItem As VSSItem)
    '出力先フォルダ設定
    Dim dir As String
   
    dir = CreateDir(objItem)
    objItem.Get dir & objItem.Name, VSSFLAG_EOLCRLF
End Sub

Private Sub CheckOutVSSItem(objItem As VSSItem)
    Dim dir As String
    dir = CreateDir(objItem)
    objItem.CheckOut "", dir & objItem.Name, VSSFLAG_REPREPLACE
End Sub

Private Sub CheckInVSSItem(objItem As VSSItem)
    Dim dir As String
    dir = CreateDir(objItem)
    objItem.CheckIn "", dir & objItem.Name, VSSFLAG_UPDUPDATE
End Sub

'出力先フォルダ作成
Private Function CreateDir(objItem As VSSItem) As String
    Dim i As Integer
    Dim dirs() As String
    Dim dir As String
   
    Dim file As String
    file = objItem.Spec
    file = Replace(file, "$/50Source", "")

    dirs = Split(file, "/")
    dir = OUTPUT_DIR
   
    For i = LBound(dirs) To UBound(dirs) - 1
        dir = dir & dirs(i)
        If Not mobjFileSystem.FolderExists(dir) Then
            Call FileSystem.MkDir(dir)
        End If
       
        dir = dir & "\"
    Next i
    CreateDir = dir
End Function