Deploy Access 2007 Database with SQL back end to Citrix for multiple users

问题

Situation: I recently took IT Support ownership of our Time Tracking database at my company (the old owner left). This was written in Access 2007 and uses SQL Server 2008 R2 Tables and views in the back end. We publish a locked (db.accde) version to our Citrix farm and users access it by logging into a citrix web portal and clicking on the icon for the Access Database. I have a need to move this from once server to a different server so the old one can be sunset. I tried simply copying the file on the existing server to the new server (which is running Office 2010 apps) and creating a new icon on the citrix portal to point to it.

Problem: Now that it is there only 1 person can open it at a time (used to be usable by multiple users) Also it needs to know who I am (for appropriate permissions within the DB) and it doesn't seem to have a clue. It is giving errors related to the SQL connection. The way it figures out who you are and what permissions you should have is by checking Active Directory and if you belong to the correct NT group then you can have access to additional Forms, if not you only see the basic user forms. Right now everyone who opens it from Citrix only sees the "basic user forms" regardless of the NT Groups they are assigned to.

Question: I am not an advanced developer when it comes to Access and VB. I also know very little about how Citrix works. I am wondering if when I copied the DB to the new server if there was something I didn't do that should have happened. For instance when you open the "existing link" which opens the "existing Access db" for a brief second there is a CMD screen that pops up and goes away prior to the access DB opening. on the new link that is not happening.

If anyone has any expertise they can toss my way to help me go down the right path of figuring this out it would be greatly appreciated.

回答1:

For various reasons, it is a VBscript. PowerShell could be used as well.

The "trick" is to use the user's LocalAppData folder to host the accdb file as the user always has been granted full rights here.

It worked from the first attempt. The version number is caused by minor changes, including changed names of the local folders, only.

The users received a link to a read-only copy of the script in a shared folder and - when double-clicked - ran and created a shortcut on the user's desktop for future launch of the application. Users had by default Access 2010 installed so no runtime was needed.

The script carries out these tasks:

• creates subfolders in the user's LocalAppData folder
• kills the application should it be running
• copies the current version of the application to the local folder
• copies a second copy (launched by the first for background tasks)
• creates/copies a shortcut
• writes the security settings for the application in the Registry
• launches the application (which then launches the background application)

The result is that the user at each launch updates the application, thus deployment of new application versions is "automatic".

Please study the in-line comments for details.

Option Explicit

' Launch script for PPT test/development/operation.
' Version 1.3.0
' 2013-09-15
' Cactus Data. Gustav Brock

Const DESKTOP = &H10
Const LOCALAPPDATA = &H1C

Dim objFSO
Dim objAppShell
Dim objDesktopFolder
Dim objLocalAppDataFolder
Dim objLocalFolder
Dim objRemoteFolder

Dim strLocalFolder
Dim strRemoteFolder
Dim strDesktopFolder
Dim strLocalAppDataFolder
Dim strLocalAppDataDsgFolder
Dim strLocalAppDataDsgPptFolder
Dim strDsgSubfolder
Dim strPptSubfolder
Dim strPptAppSubfolder
Dim strPptNcSuffix
Dim strAppName
Dim strAppSuffix
Dim strShortcutName
Dim strAppLocalPath
Dim strAppLocalBackPath
Dim strAppRemotePath
Dim strShortcutLocalPath
Dim strShortcutRemotePath
Dim strRegPath
Dim strRegKey
Dim strRegValue
Dim booNoColour

Dim varValue


' Adjustable parameters.
strDsgSubfolder = "DSG"
strPptSubfolder = "PPT"
strPPtNcSuffix = "NC"
' ---------------------------------------------------------------------------------
' Uncomment one folder name only:
'strPptAppSubfolder = "Development"
strPptAppSubfolder = "Operations"
'strPptAppSubfolder = "Test"
' ---------------------------------
' Indicate if the script is for the normal version (0) or the no-colour version (1):
booNoColour = 0
' ---------------------------------------------------------------------------------
strRemoteFolder = "K:\_Shared\Sales Planning\Environments\" & strPptAppSubfolder
If booNoColour = 1 Then
  strAppSuffix = strPptNcSuffix
Else
  strAppSuffix = ""
End If
strAppName = "SalesPlanningTool" & strAppSuffix & ".accdb"
If strPptAppSubfolder = "Operations" Then
  If strAppSuffix = "" Then
    strShortcutName = "RunPPT.lnk"
  Else
    strShortcutName = "RunPPT " & strAppSuffix & ".lnk"
  End If
Else
  If strAppSuffix = "" Then
    strShortcutName = "RunPPT " & strPptAppSubfolder & ".lnk"
  Else
    strShortcutName = "RunPPT " & strAppSuffix & " " & strPptAppSubfolder & ".lnk"
  End If
End If

' Enable simple error handling.
On Error Resume Next

' Find user's Desktop and AppData\Local folder.
Set objAppShell = CreateObject("Shell.Application")
Set objDesktopFolder = objAppShell.Namespace(DESKTOP)
strDesktopFolder = objDesktopFolder.Self.Path
Set objLocalAppDataFolder = objAppShell.Namespace(LOCALAPPDATA)
strLocalAppDataFolder = objLocalAppDataFolder.Self.Path

' Dynamic parameters.
strLocalAppDataDsgFolder = strLocalAppDataFolder & "\" & strDsgSubfolder
strLocalAppDataDsgPptFolder = strLocalAppDataDsgFolder & "\" & strPptSubfolder
strLocalFolder = strLocalAppDataDsgPptFolder & "\" & strPptAppSubfolder
strAppLocalPath = strLocalFolder & "\" & strAppName
strShortcutLocalPath = strDesktopFolder & "\" & strShortcutName

' Permanent parameters.
strAppRemotePath = strRemoteFolder & "\" & strAppName
strShortcutRemotePath = strRemoteFolder & "\" & strShortcutName

' Create the File System Object.
Set objFSO = CreateObject("Scripting.FileSystemObject")

If Not objFSO.FolderExists(strRemoteFolder) Then
  Call ErrorHandler("No access to " & strRemoteFolder & ".")
Else
  Set objRemoteFolder = objFSO.GetFolder(strRemoteFolder)
  ' If local folder does not exist, create the folder.
  If Not objFSO.FolderExists(strLocalFolder) Then
    If Not objFSO.FolderExists(strLocalAppDataDsgFolder) Then
      Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgFolder)
      If Not Err.Number = vbEmpty Then
        Call ErrorHandler("Folder " & strLocalAppDataDsgFolder & " could not be created.")
      End If
    End If
    If Not objFSO.FolderExists(strLocalAppDataDsgPPtFolder) Then
      Set objLocalFolder = objFSO.CreateFolder(strLocalAppDataDsgPptFolder)
      If Not Err.Number = vbEmpty Then
        Call ErrorHandler("Folder " & strLocalAppDataDsgPptFolder & " could not be created.")
      End If
    End If
    If Not objFSO.FolderExists(strLocalFolder) Then
      Set objLocalFolder = objFSO.CreateFolder(strLocalFolder)
      If Not Err.Number = vbEmpty Then
        Call ErrorHandler("Folder " & strLocalFolder & " could not be created.")
      End If
    End If
  End If
  Set objLocalFolder = objFSO.GetFolder(strLocalFolder)
End If

If Not objFSO.FileExists(strAppRemotePath) Then
  Call ErrorHandler("The application file:" & vbCrLf & strAppRemotePath & vbCrLF & "could not be found.")
Else
  ' Close a running PPT.
  Call KillTask("PPT")
  ' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
  Call AwaitProcess("taskkill.exe")
  Call KillTask("PPT Background")
  ' Wait while TaskKill is running twice to close the instance(s) of PPT and PPT Background.
  Call AwaitProcess("taskkill.exe")

  ' Copy app to local folder.
  If objFSO.FileExists(strAppLocalPath) Then
    objFSO.DeleteFile(strAppLocalPath)
    If Not Err.Number = 0 Then
      Call ErrorHandler("The application file:" & vbCrLf & strAppName & vbCrLF & "can not be refreshed/updated. It may be in use.")
    End If
  End If
  If objFSO.FileExists(strAppLocalPath) Then
    Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be replaced.")    
  Else
    objFSO.CopyFile strAppRemotePath, strAppLocalPath
    If Not Err.Number = vbEmpty Then
      Call ErrorHandler("Application could not be copied to " & strLocalFolder & ".")
    End If
    ' Create copy for PPT Background.
    strAppLocalBackPath = Replace(Replace(strAppLocalPath, ".accdb", ".accbg"), "SalesPlanningTool", "SalesPlanningToolBack")
    objFSO.CopyFile strAppLocalPath, strAppLocalBackPath
    If Not Err.Number = vbEmpty Then
      Call ErrorHandler("Background application could not be copied to " & strLocalFolder & ".")
    End If
  End If

  ' Copy shortcut.
  objFSO.CopyFile strShortcutRemotePath, strShortcutLocalPath
  If Not Err.Number = vbEmpty Then
    Call ErrorHandler("Shortcut could not be copied to your Desktop.")
  End If
End If

' Write Registry entries for Access security.
strRegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Access\Security\"
strRegValue = "VBAWarnings"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue,"REG_DWORD")

strRegKey = strRegKey & "Trusted Locations\LocationLocalAppData\"
strRegValue = "AllowSubfolders"
strRegPath = strRegKey & strRegValue
varValue = 1
Call WriteRegistry(strRegPath, varValue, "REG_DWORD")

strRegValue = "Date"
strRegPath = strRegKey & strRegValue
varValue = Now
varValue = FormatDateTime(varValue, vbShortDate) & " " & FormatDateTime(varValue, vbShortTime)
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Description"
strRegPath = strRegKey & strRegValue
varValue = "Local AppData"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

strRegValue = "Path"
strRegPath = strRegKey & strRegValue
varValue = strLocalAppDataFolder & "\"
Call WriteRegistry(strRegPath, varValue, "REG_SZ")

' Run PPT.
If objFSO.FileExists(strAppLocalPath) Then
  Call RunApp(strAppLocalPath, False)
Else
  Call ErrorHandler("The local application file:" & vbCrLf & strAppLocalPath & vbCrLF & "could not be found.")    
End If

Set objRemoteFolder = Nothing
Set objLocalFolder = Nothing
Set objLocalAppDataFolder = Nothing
Set objDesktopFolder = Nothing
Set objAppShell = Nothing
Set objFSO = Nothing

WScript.Quit


' Supporting subfunctions
' -----------------------

Sub RunApp(ByVal strFile, ByVal booBackground)

  Dim objShell
  Dim intWindowStyle

  ' Open as default foreground application.
  intWindowStyle = 1

  Set objShell = CreateObject("WScript.Shell")
  objShell.Run Chr(34) & strFile & Chr(34), intWindowStyle, False
  Set objShell = Nothing

End Sub


Sub KillTask(ByVal strWindowTitle)

  Dim objShell

  Set objShell = CreateObject("WScript.Shell")
  objShell.Run "TaskKill.exe /FI ""WINDOWTITLE eq " & strWindowTitle & """", 7, False
  Set objShell = Nothing

End Sub


Sub AwaitProcess(ByVal strProcess)

  Dim objSvc
  Dim strQuery
  Dim colProcess
  Dim intCount

  Set objSvc = GetObject("winmgmts:root\cimv2")
  strQuery = "select * from win32_process where name='" & strProcess & "'"

  Do 
    Set colProcess = objSvc.Execquery(strQuery)
    intCount = colProcess.Count
    If intCount > 0 Then
      WScript.Sleep 300
    End If
  Loop Until intCount = 0

  Set colProcess = Nothing
  Set objSvc = Nothing

End Sub


Sub WriteRegistry(ByVal strRegPath, ByVal varValue, ByVal strRegType)
  ' strRegType should be: 
  '   "REG_SZ" for a string
  '   "REG_DWORD" for an integer
  '   "REG_BINARY" for a binary or boolean
  '   "REG_EXPAND_SZ" for an expandable string

  Dim objShell

  Set objShell = CreateObject("WScript.Shell")

  Call objShell.RegWrite(strRegPath, varValue, strRegType)

  Set objShell = Nothing

End Sub


Sub ErrorHandler(Byval strMessage)

  Set objRemoteFolder = Nothing
  Set objLocalFolder = Nothing
  Set objLocalAppDataFolder = Nothing
  Set objDesktopFolder = Nothing
  Set objAppShell = Nothing
  Set objFSO = Nothing
  WScript.Echo strMessage
  WScript.Quit

End Sub

来源：https://stackoverflow.com/questions/34097886/deploy-access-2007-database-with-sql-back-end-to-citrix-for-multiple-users