I just rebuilt my .mdb backend in Access 2007 to the new .accdb format back end. All works fine..except...
I had relinking code which allowed the user to relocate the backend file on start up. Now I tried using the code to relink to the accdb backend and the code fails. (it isn't as simple as changing .mdb to .accsb in the code apparently!)
On start up, the code runs and the app starts only if the backend is located in its original split location. If I try to point to a different location, the code doesn't recognize the backend file.
Can someone help me make the code which ran just fine with the .mdb backend. A macro calls "reattachtables" and "AreTables Attached" The code was as follows:
"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RefreshTableLinks '
' '
' This module contains functions that refresh the '
' links to Northwind tables if they aren't available. '
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "COMDLG32.DLL" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Type MSA_OPENFILENAME
' Filter string used for the Open dialog filters.
' Use MSA_CreateFilterString() to create this.
' Default = All Files, *.*
strFilter As String
' Initial Filter to display.
' Default = 1.
lngFilterIndex As Long
' Initial directory for the dialog to open in.
' Default = Current working directory.
strInitialDir As String
' Initial file name to populate the dialog with.
' Default = "".
strInitialFile As String
strDialogTitle As String
' Default extension to append to file if user didn't specify one.
' Default = System Values (Open File, Save File).
strDefaultExtension As String
' Flags (see constant list) to be used.
' Default = no flags.
lngFlags As Long
' Full path of file picked. When the File Open dialog box is
' presented, if the user picks a nonexistent file,
' only the text in the "File Name" box is returned.
strFullPathReturned As String
' File name of file picked.
strFileNameReturned As String
' Offset in full path (strFullPathReturned) where the file name
' (strFileNameReturned) begins.
intFileOffset As Integer
' Offset in full path (strFullPathReturned) where the file extension begins.
intFileExtension As Integer
End Type
Const ALLFILES = "All Files"
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Function ReattachTables(strDataACCDB As String) As Integer
Const NONEXISTENT_TABLE = 3011
Const DATAACCDB_NOT_FOUND = 3024
Const ACCESS_DENIED = 3051
Const READ_ONLY_DATABASE = 3027
' For file dialog
Dim strFileName As String
Dim strSearchPath As String
Dim strTemp As String
Dim varRet As Variant
Dim strAccessDir As String
' For setting attachments.
Dim curDB As Database
Dim curTableDef As TableDef
Dim intNumberOfTables As Integer
Dim intTableCount As Integer
Dim strTable As String
Dim strSourceTableName As String
Dim intI As Integer
' Get Location of ACCDB file
strFileName = GetACCDBName(strDataACCDB)
strFileName = Trim(strFileName)
If strFileName = "" Then
MsgBox "You can't run the application until you locate the " & strDataACCDB & " database", 16, "Can't run the " & AppName()
GoTo ReattachTables_Failed
End If
' Loop through all tables, reattaching those with nonzero-length
' connect strings.
Set curDB = DBEngine.Workspaces(0).Databases(0)
intNumberOfTables = curDB.TableDefs.Count - 1
varRet = SysCmd(SYSCMD_INITMETER, "Attaching tables", intNumberOfTables)
intTableCount = 1
intI = 0
Do_Next_Table:
Set curTableDef = curDB.TableDefs(intI)
If InStr(curTableDef.Connect, strDataACCDB) > 0 Then
Err = 0
' *CRITICAL NOTE*
' Depending on the method used to update the link,
' the loop for walking the tabledefs collection
' needs to be modified below.
' Method "A" - .Refreshlink
curTableDef.Connect = ";DATABASE=" & strFileName
curTableDef.RefreshLink
' Method "B" - Delete and recreate table link
' Another method to reattach tables
' Note that this can loose certain table attributes.
' May not want to use in all cases
'strTable = curTableDef.Name
'strSourceTableName = curTableDef.SourceTableName
'Err = 0
'curDB.TableDefs.Delete strTable
'Set curTableDef = curDB.CreateTableDef(strTable)
'curTableDef.SourceTableName = strSourceTableName
'curTableDef.Connect = ";DATABASE=" & strFileName
'curDB.TableDefs.Append curTableDef
If Err <> 0 Then
If Err = NONEXISTENT_TABLE Then
MsgBox "File '" & strFileName & "' does not contain required table '" & curTableDef.SourceTableName & "'", 16, "Can't run the " & AppName()
ElseIf Err = DATAACCDB_NOT_FOUND Then
MsgBox "You can't run the application until you locate the " & strDataACCDB & " database", 16, "Can't run the " & AppName()
ElseIf Err = ACCESS_DENIED Then
MsgBox "Couldn't open " & strFileName & " because it is read-only or it is located on a read-only share.", 16, "Can't run the " & AppName()
ElseIf Err = READ_ONLY_DATABASE Then
MsgBox "Can't reattach tables because" & strDataACCDB & "is read-only or is located on a read-only share.", 16, "Can't run the " & AppName()
Else
MsgBox Error, 16, "Can't run the " & AppName()
End If
varRet = SysCmd(SYSCMD_REMOVEMETER)
GoTo ReattachTables_Failed
End If
' NOTE: If using method "B", comment out the next line
' of code and uncomment the line after that
intI = intI + 1
'intNumberOfTables = intNumberOfTables - 1
intTableCount = intTableCount + 1
varRet = SysCmd(SYSCMD_UPDATEMETER, intTableCount)
Else
intI = intI + 1
End If
If intI <= intNumberOfTables Then GoTo Do_Next_Table
ReattachTables_Exit:
ReattachTables = True
varRet = SysCmd(SYSCMD_REMOVEMETER)
Set curDB = Nothing
Exit Function
ReattachTables_Failed:
ReattachTables = False
Set curDB = Nothing
Application.Quit
End Function
Function AreTablesAttached(strDataACCDB As String, strTableName As String) As Integer
Dim curDB As Database
Dim curTableDef As TableDef
Dim MyRecords As Recordset
Dim intRet As Integer
' Open attached table to see if connection information is correct.
' Execute reattach if attachments are broken.
' Otherwise Exit if connection information is correct.
AreTablesAttached = False
On Error Resume Next
Err = 0
Set curDB = DBEngine.Workspaces(0).Databases(0)
Set MyRecords = curDB.OpenRecordset(strTableName)
If Err = 0 Then
MyRecords.Close
Else
intRet = ReattachTables(strDataACCDB)
If Not (intRet) Then
AreTablesAttached = False
Application.Quit
End If
End If
If Not MyRecords Is Nothing Then
MyRecords.Close
Set MyRecords = Nothing
End If
Set curDB = Nothing
End Function
Function GetACCDBName(strSearchPath) As String
' Displays the Open dialog box for the user to locate
' the Northwind database. Returns the full path to Northwind.
Dim msaof As MSA_OPENFILENAME
' Set options for the dialog box.
msaof.strDialogTitle = "PLEASE LOCATE THE FILE - " & strSearchPath
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString("Databases", "*.accdb")
' Call the Open dialog routine.
MSA_GetOpenFileName msaof
' Return the path and file name.
GetACCDBName = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
Dim strFilter As String
Dim intRet As Integer
Dim intNum As Integer
intNum = UBound(varFilt)
If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
Else
strFilter = ""
End If
MSA_CreateFilterString = strFilter
End Function
Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.accdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.
Dim strFilter As String
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strFilter = ""
intNum = 0
intPos = 1
intLastPos = 1
' Add strings as long as we find bars.
' Ignore any empty strings (not allowed).
Do
intPos = InStr(intLastPos, strFilterIn, "|")
If (intPos > intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
intNum = intNum + 1
intLastPos = intPos + 1
ElseIf (intPos = intLastPos) Then
intLastPos = intPos + 1
End If
Loop Until (intPos = 0)
' Get last string if it exists (assuming strFilterIn was not bar terminated).
intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
intNum = intNum + 1
End If
' Add *.* if there's no extension for the last string.
If intNum Mod 2 = 1 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
' Add terminating NULL if we have any filter.
If strFilter <> "" Then
strFilter = strFilter & vbNullChar
End If
MSA_ConvertFilterString = strFilter
End Function
Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_t
F msaof, of
of.flags = of.flags Or OFN_HIDEREADONLY
intRet = GetSaveFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetSaveFileName = intRet
End Function
Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetSaveFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetSaveFileName = strRet
End Function
Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_tF msaof, of
intRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
End Function
Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetOpenFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetOpenFileName = strRet
End Function
Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
msaof.strFileNameReturned = of.lpstrFileTitle
msaof.intFileOffset = of.nFileOffset
msaof.intFileExtension = of.nFileExtension
End Sub
Private Sub MSAOF_tF(msaof As MSA_OPENFILENAME, of As OPENFILENAME)
' This sub converts from the Microsoft Access structure to the Win32 structure.
Dim strFile As String * 512
' Initialize some parts of the structure.
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
If msaof.strFilter = "" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
Else
of.lpstrFilter = msaof.strFilter
End If
of.nFilterIndex = msaof.lngFilterIndex
of.lpstrFile = msaof.strInitialFile _
& String(512 - Len(msaof.strInitialFile), 0)
of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir
of.lpstrDefExt = msaof.strDefaultExtension
of.flags = msaof.lngFlags
of.lStructSize = Len(of)
End Sub
?
I had relinking code which allowed the user to relocate the backend file on start up. Now I tried using the code to relink to the accdb backend and the code fails. (it isn't as simple as changing .mdb to .accsb in the code apparently!)
On start up, the code runs and the app starts only if the backend is located in its original split location. If I try to point to a different location, the code doesn't recognize the backend file.
Can someone help me make the code which ran just fine with the .mdb backend. A macro calls "reattachtables" and "AreTables Attached" The code was as follows:
"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RefreshTableLinks '
' '
' This module contains functions that refresh the '
' links to Northwind tables if they aren't available. '
' '
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit ' Require variables to be declared before being used.
Option Compare Database ' Use database order for string comparisons.
Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Declare Function GetSaveFileName Lib "COMDLG32.DLL" Alias _
"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Boolean
Type MSA_OPENFILENAME
' Filter string used for the Open dialog filters.
' Use MSA_CreateFilterString() to create this.
' Default = All Files, *.*
strFilter As String
' Initial Filter to display.
' Default = 1.
lngFilterIndex As Long
' Initial directory for the dialog to open in.
' Default = Current working directory.
strInitialDir As String
' Initial file name to populate the dialog with.
' Default = "".
strInitialFile As String
strDialogTitle As String
' Default extension to append to file if user didn't specify one.
' Default = System Values (Open File, Save File).
strDefaultExtension As String
' Flags (see constant list) to be used.
' Default = no flags.
lngFlags As Long
' Full path of file picked. When the File Open dialog box is
' presented, if the user picks a nonexistent file,
' only the text in the "File Name" box is returned.
strFullPathReturned As String
' File name of file picked.
strFileNameReturned As String
' Offset in full path (strFullPathReturned) where the file name
' (strFileNameReturned) begins.
intFileOffset As Integer
' Offset in full path (strFullPathReturned) where the file extension begins.
intFileExtension As Integer
End Type
Const ALLFILES = "All Files"
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As Long
nMaxCustrFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustrData As Long
lpfnHook As Long
lpTemplateName As Long
End Type
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_CREATEPROMPT = &H2000
Const OFN_EXPLORER = &H80000
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOVALIDATE = &H100
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_PATHMUSTEXIST = &H800
Const OFN_READONLY = &H1
Const OFN_SHOWHELP = &H10
Function ReattachTables(strDataACCDB As String) As Integer
Const NONEXISTENT_TABLE = 3011
Const DATAACCDB_NOT_FOUND = 3024
Const ACCESS_DENIED = 3051
Const READ_ONLY_DATABASE = 3027
' For file dialog
Dim strFileName As String
Dim strSearchPath As String
Dim strTemp As String
Dim varRet As Variant
Dim strAccessDir As String
' For setting attachments.
Dim curDB As Database
Dim curTableDef As TableDef
Dim intNumberOfTables As Integer
Dim intTableCount As Integer
Dim strTable As String
Dim strSourceTableName As String
Dim intI As Integer
' Get Location of ACCDB file
strFileName = GetACCDBName(strDataACCDB)
strFileName = Trim(strFileName)
If strFileName = "" Then
MsgBox "You can't run the application until you locate the " & strDataACCDB & " database", 16, "Can't run the " & AppName()
GoTo ReattachTables_Failed
End If
' Loop through all tables, reattaching those with nonzero-length
' connect strings.
Set curDB = DBEngine.Workspaces(0).Databases(0)
intNumberOfTables = curDB.TableDefs.Count - 1
varRet = SysCmd(SYSCMD_INITMETER, "Attaching tables", intNumberOfTables)
intTableCount = 1
intI = 0
Do_Next_Table:
Set curTableDef = curDB.TableDefs(intI)
If InStr(curTableDef.Connect, strDataACCDB) > 0 Then
Err = 0
' *CRITICAL NOTE*
' Depending on the method used to update the link,
' the loop for walking the tabledefs collection
' needs to be modified below.
' Method "A" - .Refreshlink
curTableDef.Connect = ";DATABASE=" & strFileName
curTableDef.RefreshLink
' Method "B" - Delete and recreate table link
' Another method to reattach tables
' Note that this can loose certain table attributes.
' May not want to use in all cases
'strTable = curTableDef.Name
'strSourceTableName = curTableDef.SourceTableName
'Err = 0
'curDB.TableDefs.Delete strTable
'Set curTableDef = curDB.CreateTableDef(strTable)
'curTableDef.SourceTableName = strSourceTableName
'curTableDef.Connect = ";DATABASE=" & strFileName
'curDB.TableDefs.Append curTableDef
If Err <> 0 Then
If Err = NONEXISTENT_TABLE Then
MsgBox "File '" & strFileName & "' does not contain required table '" & curTableDef.SourceTableName & "'", 16, "Can't run the " & AppName()
ElseIf Err = DATAACCDB_NOT_FOUND Then
MsgBox "You can't run the application until you locate the " & strDataACCDB & " database", 16, "Can't run the " & AppName()
ElseIf Err = ACCESS_DENIED Then
MsgBox "Couldn't open " & strFileName & " because it is read-only or it is located on a read-only share.", 16, "Can't run the " & AppName()
ElseIf Err = READ_ONLY_DATABASE Then
MsgBox "Can't reattach tables because" & strDataACCDB & "is read-only or is located on a read-only share.", 16, "Can't run the " & AppName()
Else
MsgBox Error, 16, "Can't run the " & AppName()
End If
varRet = SysCmd(SYSCMD_REMOVEMETER)
GoTo ReattachTables_Failed
End If
' NOTE: If using method "B", comment out the next line
' of code and uncomment the line after that
intI = intI + 1
'intNumberOfTables = intNumberOfTables - 1
intTableCount = intTableCount + 1
varRet = SysCmd(SYSCMD_UPDATEMETER, intTableCount)
Else
intI = intI + 1
End If
If intI <= intNumberOfTables Then GoTo Do_Next_Table
ReattachTables_Exit:
ReattachTables = True
varRet = SysCmd(SYSCMD_REMOVEMETER)
Set curDB = Nothing
Exit Function
ReattachTables_Failed:
ReattachTables = False
Set curDB = Nothing
Application.Quit
End Function
Function AreTablesAttached(strDataACCDB As String, strTableName As String) As Integer
Dim curDB As Database
Dim curTableDef As TableDef
Dim MyRecords As Recordset
Dim intRet As Integer
' Open attached table to see if connection information is correct.
' Execute reattach if attachments are broken.
' Otherwise Exit if connection information is correct.
AreTablesAttached = False
On Error Resume Next
Err = 0
Set curDB = DBEngine.Workspaces(0).Databases(0)
Set MyRecords = curDB.OpenRecordset(strTableName)
If Err = 0 Then
MyRecords.Close
Else
intRet = ReattachTables(strDataACCDB)
If Not (intRet) Then
AreTablesAttached = False
Application.Quit
End If
End If
If Not MyRecords Is Nothing Then
MyRecords.Close
Set MyRecords = Nothing
End If
Set curDB = Nothing
End Function
Function GetACCDBName(strSearchPath) As String
' Displays the Open dialog box for the user to locate
' the Northwind database. Returns the full path to Northwind.
Dim msaof As MSA_OPENFILENAME
' Set options for the dialog box.
msaof.strDialogTitle = "PLEASE LOCATE THE FILE - " & strSearchPath
msaof.strInitialDir = strSearchPath
msaof.strFilter = MSA_CreateFilterString("Databases", "*.accdb")
' Call the Open dialog routine.
MSA_GetOpenFileName msaof
' Return the path and file name.
GetACCDBName = Trim(msaof.strFullPathReturned)
End Function
Function MSA_CreateFilterString(ParamArray varFilt() As Variant) As String
' Creates a filter string from the passed in arguments.
' Returns "" if no argumentss are passed in.
' Expects an even number of argumentss (filter name, extension), but
' if an odd number is passed in, it appends "*.*".
Dim strFilter As String
Dim intRet As Integer
Dim intNum As Integer
intNum = UBound(varFilt)
If (intNum <> -1) Then
For intRet = 0 To intNum
strFilter = strFilter & varFilt(intRet) & vbNullChar
Next
If intNum Mod 2 = 0 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
strFilter = strFilter & vbNullChar
Else
strFilter = ""
End If
MSA_CreateFilterString = strFilter
End Function
Function MSA_ConvertFilterString(strFilterIn As String) As String
' Creates a filter string from a bar ("|") separated string.
' The string should pairs of filter|extension strings, i.e. "Access Databases|*.accdb|All Files|*.*"
' If no extensions exists for the last filter pair, *.* is added.
' This code will ignore any empty strings, i.e. "||" pairs.
' Returns "" if the strings passed in is empty.
Dim strFilter As String
Dim intNum As Integer, intPos As Integer, intLastPos As Integer
strFilter = ""
intNum = 0
intPos = 1
intLastPos = 1
' Add strings as long as we find bars.
' Ignore any empty strings (not allowed).
Do
intPos = InStr(intLastPos, strFilterIn, "|")
If (intPos > intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos) & vbNullChar
intNum = intNum + 1
intLastPos = intPos + 1
ElseIf (intPos = intLastPos) Then
intLastPos = intPos + 1
End If
Loop Until (intPos = 0)
' Get last string if it exists (assuming strFilterIn was not bar terminated).
intPos = Len(strFilterIn)
If (intPos >= intLastPos) Then
strFilter = strFilter & Mid(strFilterIn, intLastPos, intPos - intLastPos + 1) & vbNullChar
intNum = intNum + 1
End If
' Add *.* if there's no extension for the last string.
If intNum Mod 2 = 1 Then
strFilter = strFilter & "*.*" & vbNullChar
End If
' Add terminating NULL if we have any filter.
If strFilter <> "" Then
strFilter = strFilter & vbNullChar
End If
MSA_ConvertFilterString = strFilter
End Function
Private Function MSA_GetSaveFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the file save dialog.
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_t
F msaof, ofof.flags = of.flags Or OFN_HIDEREADONLY
intRet = GetSaveFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetSaveFileName = intRet
End Function
Function MSA_SimpleGetSaveFileName() As String
' Opens the file save dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetSaveFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetSaveFileName = strRet
End Function
Private Function MSA_GetOpenFileName(msaof As MSA_OPENFILENAME) As Integer
' Opens the Open dialog.
Dim of As OPENFILENAME
Dim intRet As Integer
MSAOF_t
F msaof, ofintRet = GetOpenFileName(of)
If intRet Then
OF_to_MSAOF of, msaof
End If
MSA_GetOpenFileName = intRet
End Function
Function MSA_SimpleGetOpenFileName() As String
' Opens the Open dialog with default values.
Dim msaof As MSA_OPENFILENAME
Dim intRet As Integer
Dim strRet As String
intRet = MSA_GetOpenFileName(msaof)
If intRet Then
strRet = msaof.strFullPathReturned
End If
MSA_SimpleGetOpenFileName = strRet
End Function
Private Sub OF_to_MSAOF(of As OPENFILENAME, msaof As MSA_OPENFILENAME)
' This sub converts from the Win32 structure to the Microsoft Access structure.
msaof.strFullPathReturned = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
msaof.strFileNameReturned = of.lpstrFileTitle
msaof.intFileOffset = of.nFileOffset
msaof.intFileExtension = of.nFileExtension
End Sub
Private Sub MSAOF_t
F(msaof As MSA_OPENFILENAME, of As OPENFILENAME)' This sub converts from the Microsoft Access structure to the Win32 structure.
Dim strFile As String * 512
' Initialize some parts of the structure.
of.hwndOwner = Application.hWndAccessApp
of.hInstance = 0
of.lpstrCustomFilter = 0
of.nMaxCustrFilter = 0
of.lpfnHook = 0
of.lpTemplateName = 0
of.lCustrData = 0
If msaof.strFilter = "" Then
of.lpstrFilter = MSA_CreateFilterString(ALLFILES)
Else
of.lpstrFilter = msaof.strFilter
End If
of.nFilterIndex = msaof.lngFilterIndex
of.lpstrFile = msaof.strInitialFile _
& String(512 - Len(msaof.strInitialFile), 0)
of.nMaxFile = 511
of.lpstrFileTitle = String(512, 0)
of.nMaxFileTitle = 511
of.lpstrTitle = msaof.strDialogTitle
of.lpstrInitialDir = msaof.strInitialDir
of.lpstrDefExt = msaof.strDefaultExtension
of.flags = msaof.lngFlags
of.lStructSize = Len(of)
End Sub
?
