Excel 应用05_自动从VSS上取文件_VBA

最新推荐文章于 2021-02-28 22:07:51 发布

原创最新推荐文章于 2021-02-28 22:07:51 发布 · 2.1k 阅读

1 ·

CC 4.0 BY-SA版权

文章标签：

#vss #vba #excel #string #integer #user

このマクロはVSS（Visual SourceSafe）から指定されたファイルを自動的にダウンロードします。Excelシートに記載された情報に基づいて、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より、指定したファイルを取得するマクロ（パス入り） '作成者：　ThinkinGa1l '作成日：　2010/01/29 '修正履歴：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("VSSFM")'sheet name is VSSFM->VSS's file management '設定値取・ 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, 8)) Call OutputVSSItem(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, 8) & "] が見つかりません。" 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 Function CreateDir(objItem As VSSItem) As String Dim i As Integer Dim dirs() As String Dim dir As String dirs = Split(objItem.Spec, "/") 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