Excel 2003 sp 3 on Windows XP

[SJohnE]

I have a template that does some checks to make sure the user has the right version and that they are running it from the right directory. It needs to be in the correct directory because it must work with the right databse.

The code in my template checks the properties to get the current path that it is opened from. The problem is that for some reason the template properties are blank when I open the template. Initially it was working but all of a sudden it quit. I am protecting the template so that users can not delete columns or change the names of column headings.

I even tried creating it as an xls file (works perfectly) and saving as a template. As soon as it becomes a template the properties go away.

My Code:
Option Explicit

'Variables that are accessible from various procedures and functions
Public XLSVer$, MDBVer$, XLSTitle$, MDBWrkDir$, SWDir$, XLSSrcDir$

Public Sub Autpen()
'Created by: Steve Ellertson
'Created on: 12/6/11
'Comments: This procedure performs the following:
'1. Identifies current directory of XLT file stores to XLSSrcDir$
'2. Retrieves template version (xlt)stores to XLSVer$
'3. Retrieves EPSI mdb front end version stores to MDBVer$
'4. Retrieves the working directory path from the EPSI_be mdb config file, stores to MDBWrkDir$
'5. Retreives the Software Directory from the EPSI_be.mdb Config file, stores to SWDir$
'6. Compares the two directories, if they do not match provide msg and close
'7. Compares the two versions they must match, if they don't provide msg and close
'_________________________________________________________________

Dim db As DAO.Database
Dim ws As DAO.Workspace
Dim rsWD As Recordset
Dim rsSW As Recordset
Dim qry As DAO.QueryDef
Dim RunTimeSrc$, sqlWD$, sqlSW$

Dim DSOXL, DSODB As DSOFile.OleDocumentProperties

'Identify the current directory
XLSSrcDir$ = ActiveWorkbook.Path
'MsgBox XLSSrcDir$ 'Troubleshooting Only

Set DSOXL = New DSOFile.OleDocumentProperties
Set DSODB = New DSOFile.OleDocumentProperties

'Identify the tables for which to check properties
DSOXL.Open sfilename:=XLSSrcDir$ & "\EPSI-TAG-IMPORT-TEMPLATE.xlt"
DSODB.Open sfilename:=XLSSrcDir$ & "\EPSI.mdb"

'Get appropriate values for the Excel template data variables
'XLSVer$ = DSOXL.CustomProperties.Item("tempversion").Value
XLSVer$ = DSOXL.SummaryProperties.Comments
XLSTitle$ = DSOXL.SummaryProperties.Title & ". Version: "

'Retrieve Dir data from EPSI_be.mdb config file.
RunTimeSrc$ = XLSSrcDir$ & "\" & "EPSI.mdb"

sqlWD$ = "Select EPSI_Config.Lookup_Value from EPSI_Config where EPSI_CONFIG.Lookup_Type = 'Working Directory'"

sqlSW$ = "Select EPSI_Config.Lookup_Value from EPSI_Config where EPSI_CONFIG.Lookup_Type = 'Software Directory'"

Set ws = DBEngine.Workspaces(0)
Set db = ws.OpenDatabase(RunTimeSrc$, False, False, "MS Access")
Set rsWD = db.OpenRecordset(sqlWD$)
Set rsSW = db.OpenRecordset(sqlSW$)

MDBWrkDir$ = rsWD!Lookup_Value
SWDir$ = rsSW!Lookup_Value

'Get appropriate values for Access data variables
MDBVer$ = DSODB.SummaryProperties.Comments

'Build the window title caption and window status text
ActiveWindow.Caption = XLSTitle$ & ". " & XLSVer$
Application.StatusBar = "Press Ctrl + L to save template to Working Directory"

'Is the template opened from the directory in the Config file
If XLSSrcDir$ <> SWDir$ Then

MsgBox "You must use the template that resides with the EPSI software in" & vbCrLf & _
SWDir$, vbCritical, "TEMPLATE ERROR"
db.Close
Set ws = Nothing
Set db = Nothing
Set rsWD = Nothing
Set rsSW = Nothing
DSOXL.Close
DSODB.Close
Application.Quit
Else
'database and xls versions should always match.
If XLSVer$ <> MDBVer$ Then
MsgBox "The EPSI Database " & MDBVer$ & vbCrLf & _
"and this Template " & XLSVer$ & " are not in sync." & vbCrLf & vbCrLf & _
"Versions must match. Use the current version of the template" & vbCrLf & _
"that resides in the same directory as the EPSI software." & vbCrLf & vbCrLf & _
"\\Wtps0084\bps_data\BPS\Data_Imports\EPSI", vbCritical, "VERSION CONFLICT"
db.Close
Set ws = Nothing
Set db = Nothing
Set rsWD = Nothing
Set rsSW = Nothing
DSOXL.Close
DSODB.Close
Application.Quit
End If
End If
'clean up
db.Close
Set ws = Nothing
Set db = Nothing
Set rsWD = Nothing
Set rsSW = Nothing
DSOXL.Close
DSODB.Close
End Sub

Public Sub LoadWkgDir()
'Created by: Steve Ellertson
'Created on: 12/8/11
'Comments: This procedure performs the following:
'1. Confirms action
'2. Asks user for the file name
'3. Adds the "t_" prefix to the file name entered by the user in item 2.
'4. Saves the file to the working directory using the path stored in
' in memory varialbe MDBWrkDir$ populated in the Autpen procedure.
'_________________________________________________________________
Dim NewName$, response$, SaveAs$, App$
Dim appaccess As Object

'Confirm Action
response$ = MsgBox("You are about to save this file in" & vbCrLf & _
"the EPSI working directory. This should only be done" & vbCrLf & _
"when you are ready to import the data into BPS." & vbCrLf & vbCrLf & _
"Do you wish to continue?", vbExclamation + vbYesNo, "CONFIRM ACTION")

'Based on response ask for the file name
If response$ = vbYes Then
SaveAs$ = InputBox("Enter name of file." & vbCrLf & _
"DO NOT include the prefix of t_.", "SAVE AS")
'Add appropriate prefix to file name
SaveAs$ = "t_" & SaveAs$

'Save the file in the working directory.
ChDir MDBWrkDir$
ActiveWorkbook.SaveAs Filename:=SaveAs$, FileFormat:=xlNormal, Password:="", WriteRESPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False

'Give the user feedback that the file has been saved in the working directory.
MsgBox "Your file has been loaded into the working directory." & vbCrLf & vbCrLf & _
MDBWrkDir$ & SaveAs$, , "SAVE COMPLETE"

'Ask if the user wants to open the EPSI database for processing.
response$ = MsgBox("Do you wish to open the EPSI database" & vbCrLf & _
"for processing?", vbYesNo, "START PROCESSING")

If response$ = vbYes Then
App$ = SWDir$ & "\EPSI.mdb"
Set appaccess = CreateObject("Access.Application.11")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set appaccess = GetObject(App$)
appaccess.Visible = True
End If
Else
Exit Sub
End If

'clean up
response$ = Empty
SaveAs$ = Empty
response$ = MsgBox("Do you wish to close the Excel template?", vbYesNo, "CLOSE EXCEL")
If response$ = vbYes Then
Application.Quit
End If
End Sub


S J E
If I am not learning, then I am coasting, if I am coasting I must be going down hill.

 

[SkipVought]

hi,

Please post VBA in forum707.

Skip,
[sub]
Just traded in my old subtlety...
for a NUANCE![/sub]