VB SourceSafe Auto Backup

Option Explicit

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

Private Const SYNCHRONIZE = &H100000  '进程同步

Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long

Private Const INFINITE = &HFFFFFFFF

 

Public Sub Main()

    Dim objVSSDatabase  As VSSDatabase
    Dim objVSSProject   As VSSItem
    Dim strErrorDescription As String
   
    Dim wzipexe As String    ' winzip 执行文件的位置
    Dim wcmd As String        ' Shell 指令
    Dim retval As Double
   
    Dim strFileName As String
    Dim arr() As String

    Dim strPara() As String
    Dim strSrcServer As String
    Dim strSrcPath As String
    Dim strSrcUser As String
    Dim strSrcPwd As String
    Dim strDstServer As String
    Dim strDstPath As String
    Dim strDstUser As String
    Dim strDstPwd As String
   
On Error GoTo Error_Handler

'    strPara = Split(Command, "|")
'    strSrcServer = strPara(0)
'    strSrcPath = strPara(1)
'    strSrcUser = strPara(2)
'    strSrcPwd = strPara(3)
'    strDstServer = strPara(4)
'    strDstPath = strPara(5)
'    strDstUser = strPara(6)
'    strDstPwd = strPara(7)
   
    strSrcServer = "//Source/bo3vss$/srcsafe.ini"
    strSrcPath = "$/BMS-BACH"
    strSrcUser = "*******"
    strSrcPwd = "*******"
    strDstServer = "//Dest$/srcsafe.ini"
    strDstPath = "$/BMS/Backup Files"
    strDstUser = "*******"
    strDstPwd = "*******"
    
   

    Dim fs As FileSystemObject
    Set fs = New FileSystemObject
    Set objVSSDatabase = New VSSDatabase
    objVSSDatabase.Open strSrcServer, strSrcUser, strSrcPwd

    Set objVSSProject = objVSSDatabase.VSSItem(strSrcPath, False)
    objVSSProject.Get Local:="D:/LocalTemp", iFlags:=VSSFLAG_TIMENOW + VSSFLAG_REPREPLACE + VSSFLAG_RECURSYES + VSSFLAG_FORCEDIRNO + VSSFLAG_EOLCRLF

    Set objVSSDatabase = Nothing

    'Delete
    fs.DeleteFolder "D:/LocalTemp/S0(Requirment)", True
    fs.DeleteFile "D:/LocalTemp/S1(Exteneral Spec)/Meeting Minutes/FIN_20060414(CEA,CEG,BTP,INV920).MP3", True
   
    arr = Split(strSrcPath, "/")
    strFileName = arr(UBound(arr)) & "-" & Format(Now, "yyyyMMdd") & ".zip"
    wzipexe = "D:/program files/winzip/WINzip32" ' winzip 执行文件的位置
    wcmd = wzipexe & " -a -r " & "D:/" & strFileName & " " & "D:/LocalTemp/*.*"
    'retval = Shell(wcmd, 6)
    OpenFileWait wcmd

    Set objVSSDatabase = New VSSDatabase
    objVSSDatabase.Open strDstServer, strDstUser, strDstPwd
    Set objVSSProject = objVSSDatabase.VSSItem(strDstPath, False)
    objVSSProject.Add "D:/" & strFileName
    Set objVSSProject = Nothing
    Set objVSSDatabase = Nothing

    fs.DeleteFile "D:/" & strFileName, True
    fs.DeleteFolder "D:/LocalTemp", True
   
'    MsgBox "OK"

    Exit Sub
Error_Handler:
    Set objVSSProject = Nothing
    Set objVSSDatabase = Nothing
    strErrorDescription = "[(" & 1051 + vbObjectError & ")(" & App.Title & ")(cmdGet_Click)]" & Err.Description
    MsgBox Err.Description
    Screen.MousePointer = 0
End Sub

 

Private Sub OpenFileWait(tkFileName As String)
Dim wndID As Long
Dim wnd As Long
  wndID = Shell(tkFileName, 6)

  wnd = OpenProcess(SYNCHRONIZE, 0, wndID)

  WaitForSingleObject wnd, INFINITE

  CloseHandle wnd

End Sub