创建文件夹（可信），MDE和快捷方式的副本

时间：2015-05-25 00:13:56

标签： vbscript registry

我已经编写了一个我认为可行的脚本，但我知道的唯一代码是一些VBA。从来没有尝试过创建一个vbscript，所以如果有些错误是明显的，我很抱歉，但指点和更正将会受到赞赏。

我希望我能为我公司的用户提供此脚本的链接并让他们运行它。它将在其C盘上创建一个文件夹，使其成为受信任的位置，将数据库前端从服务器复制到其中，并在其桌面上创建一个链接到新文件的快捷方式。 （我希望在制作新版本时该文件会自动更新 - 我认为这有点可行）。

代码来自各种来源，包括我自己的心灵，但是我需要下载Visual Studio来测试吗？稍微关注一下，因为它包括创建一个注册表项，如果一切都发生了可怕的错误，我就不知道如何停止代码。我甚至不知道如何打破一个循环（虽然我想我读到了你需要两次击中 Esc 的地方）。任何关于如何表示哪个子组件是在开始时运行的子组件的提示也会很好。

编辑：代码已经修改为我的最终结果，因为它对其他人有用。请谨慎使用。更新＆＃39; vbs删除在本地驱动器上创建的文件夹。

'FrontEnd Setup
call CreateTrustedFolder

'Const HKEY_CLASSES_ROOT = &H80000000 
Const HKEY_CURRENT_USER = &H80000001 
'Const HKEY_LOCAL_MACHINE = &H80000002 
'Const HKEY_USERS = &H80000003 
'Const HKEY_CURRENT_CONFIG = &H80000005 

Dim lclFolder
Dim blnUpdate

Sub CreateTrustedFolder()
On error resume next
    Call RunAdmin
    Call FolderFileShortcut
    Call CreateReg
if err then
    MsgBox "The following error has occurred " & Err & " " & Err.Description
    exit Sub
end if
End Sub

'Run as Administrator
Sub RunAdmin()
On error resume next
If Not WScript.Arguments.Named.Exists("elevate") Then
  CreateObject("Shell.Application").ShellExecute WScript.FullName _
    , WScript.ScriptFullName & " /elevate", "", "runas", 1
  WScript.Quit
End If
if err then
    MsgBox "The following error has occurred " & Err & " " & Err.Description
    exit Sub
end if
End Sub

'Check if folder exists, add file and desktop shortcut
Sub FolderFileShortcut()
On error resume next
Dim oWS
Dim FSO
Dim svrFolder
Dim myShortcut
Dim strLocalDB
Dim strServerDB
Dim strUpdate
Dim strIcon
Dim objFile
Dim counter

Set oWS = WScript.CreateObject("WScript.Shell")
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
    svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
    lclFolder = "C:\Program Files\Orrible Database"

If (FSO.FolderExists(lclFolder)) Then 
    oWS.run "icacls """ & lclFolder & """ /reset /grant:r Users:(W) /t" '/T required for existing folders
    FSO.DeleteFolder lclFolder
    blnUpdate = True
end if
If Not (FSO.FolderExists(svrFolder)) Then
    msgbox "Unable to connect to Location Server", vbCritical, "Installation Failed"
    WScript.Quit
End If
For Each objFile in FSO.Getfolder(svrFolder).Files
    if LCase(FSO.GetExtensionName(objFile.name)) = LCase("mde") then  
        counter = counter + 1
        strServerDB = FSO.GetFileName(objFile)
    end if
Next
If strServerDB = "" or counter <> 1 then
    msgbox "Unable to locate the Front End" & strServerDB & "-" & counter, vbCritical, "Installation Failed"
    wScript.Quit
end if

strLocalDB = "Co Database.mde"
strUpdate = "DB_UpdateCheck.vbs"
strIcon = "Frontend Update.ico"
FSO.CreateFolder(lclFolder)
oWS.run "icacls """ & lclFolder & """ /grant Users:(OI)(CI)F /t" '/T required for existing folders
FSO.CopyFile svrFolder & "\" & strUpdate, lclFolder & "\" & strUpdate, True
FSO.CopyFile svrFolder & "\" & strServerDB, lclFolder & "\" & strLocalDB, True
FSO.CopyFile svrFolder & "\" & strIcon, lclFolder & "\" & strIcon, True 

strDesktop = oWS.SpecialFolders("Desktop")
set myShortcut = oWS.CreateShortcut(strDesktop + "\New Database.lnk")
myShortcut.TargetPath = lclFolder & "\" & strUpdate 
myShortcut.WindowStyle = 1
myShortcut.IconLocation = lclFolder & "\" & strIcon
myShortcut.WorkingDirectory = strDesktop
myShortcut.Save
if err then
MsgBox "The following error has occurred " & Err & " " & Err.Description
exit Sub
end if
End Sub


Sub CreateReg()
On error resume next
Dim objRegistry         'registry object
Dim strDescription      'Description of the Trusted Location
Dim strParentKey        'Registry location of Application
Dim strNewKey           'strParentKey and myFolder
Dim oWS                 'WSH shell object

strDescription = "DB Folder"
strParentKey = "Software\Microsoft\Office\15.0\Access\Security\Trusted Locations"
strNewKey = strParentKey & "\" & strDescription & "\"

Set objRegistry = GetObject("winmgmts:\\.\root\default:StdRegProv")     
'objRegistry.GetStringValue HKEY_CURRENT_USER, strParentKey & "\" & strDescription 
If Not objRegistry.EnumKey(HKEY_CURRENT_USER, strNewKey) = 0 then '0=true
    objRegistry.CreateKey HKEY_CURRENT_USER, strNewKey
    objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Path", lclFolder
    objRegistry.SetStringValue HKEY_CURRENT_USER, strNewKey, "Description", strDescription
End if
If not blnUpdate = True then
    msgbox "The Database is now available from your desktop", vbInformation, "Setup Complete"
Else
    msgbox "The update is now complete."
End if
if err then
    MsgBox "The following error has occurred " & Err & " " & Err.Description
    exit Sub
end if
End Sub

还有一个单独的Update vbs，它是在单击链接时运行的。这会检查“创建日期”是否为＆＃39;服务器上的数据库比本地驱动器上的数据库更新。新的DB名称不能与它替换的名称相同。它可能运行得有点快，但这是我已经采取的这个。

Call CheckForUpdate

Sub CheckForUpdate()
On Error Resume Next
    Dim FSO
    Dim oWS
    Dim svrFolder
    Dim lclFolder
    Dim svrFail
    Dim strLocalDB
    Dim strServerDB
    Dim lclDate
    Dim svrDate
    Dim strFileName
    Dim intDBcount
    Dim fCheck

    Set oWS = WScript.CreateObject("WScript.Shell")
    Set FSO = WScript.CreateObject("Scripting.FileSystemObject")

    svrFolder = "\\192.168.1.2\DeptFolder\DatabaseFolder\Auto-Update"
    lclFolder = "C:\Program Files\Orrible Database"
    strLocalDB = "Co Database.mde"

    If Not (FSO.FolderExists(svrFolder)) Then
        msgbox "Unable to connect to Location Server", vbCritical, "Update Check Failed"
        svrFail = True
    End If
    If Not svrFail = True Then 
        For Each fCheck in FSO.GetFolder(svrFolder).Files
            If Ucase(Right(fCheck.Name, 3))  = "MDE" Then
                intDBcount = intDBcount + 1
                strServerDB = fCheck.name
            End If
        Next
        If Not intDBcount = 1 Then
            MsgBox "Please inform the Administrator that there is a problem with the Automated Update System.", _
              vbCritical, "Update Failed (" & intDBcount & ")"
              svrFail = True 'not quit - need to see if old version available
        End If
    End If
    If Not (FSO.FolderExists(lclFolder)) Then 
        If svrFail = True Then 'If no lcl folder or server
            If Not intDBcount = 1 then WScript.Quit
            msgbox "You are unable to use the Database." & vbcrlf & _
              "Please try again when you have access to the Location Server.", _
              vbcritical, "Database Not Installed"
              WScript.Quit
        Else 'If no lclfolder, get it from svr
            'Do normal initial install
            oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True
            WScript.Quit
        End If
    Else
        If svrFail = True Then 'If lcl folder, but no svr
            'open db
            oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
            WScript.Quit
        Else 'If lcl folder and svr access, check for update.
            lclDate = fso.getfile(lclFolder & "\" & strLocalDB).DateCreated
            svrDate = fso.getfile(svrFolder & "\" & strServerDB).DateCreated
            If lclDate < svrDate Then 'Update available
                intMsg = MsgBox("An update is available - Do you wish to update now?", vbQuestion + vbYesNo, "Update Found")
                If intMsg = vbYes Then
                    oWS.Run svrFolder & "\" & "DB_Install.vbs", 1, True ',1,true should pause the code until install closes
                    oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
                    WScript.Quit
                Else
                    oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
                    WScript.Quit
                End If
            Else
                oWS.Run CHR(34) & lclFolder & "\" & strLocalDB & CHR(34)
                WScript.Quit
            End If
        End If
    End If
If err Then
    MsgBox "The following error has occurred " & Err & " " & Err.Description
    Exit Sub
End If
End Sub

0 个答案:

没有答案
相关问题
最新问题