RepairDB (2)

Public Function UniqueArray(ByRef ravarReturnArray() As Variant, ByRef
ravarSourceArray() As Variant, ByVal lngSourceElements As Long) As Long
'     'Function: UniqueArray
'     'Author:Russell Sinclair
'     'Date: March, 1997
'Purpose:Returns an array with unique values from an array w
'     ith multiple
'     'instances of values.
On Error GoTo Err_UniqueArray
Dim lngReturnElements As Long, lngI As Long, varCurrentValue As
Variant, lngJ As Long
Dim lngCurrentIndex As Long, fNoMatch As Boolean
lngReturnElements = 0
For lngI = 0 To lngSourceElements - 1
varCurrentValue = ravarSourceArray(lngI)
fNoMatch = True
lngJ = 0
Do While fNoMatch And lngJ <= lngReturnElements - 1
    If ravarReturnArray(lngJ) = varCurrentValue Then fNoMatch =
    False
    lngJ = lngJ + 1
Loop
If fNoMatch Then
    ReDim Preserve ravarReturnArray(lngReturnElements)
    ravarReturnArray(lngReturnElements) = varCurrentValue
    lngReturnElements = lngReturnElements + 1
End If
Next lngI
UniqueArray = lngReturnElements
Exit_UniqueArray:
Exit Function
Err_UniqueArray:
MsgBox Err.Description
Resume Exit_UniqueArray
End Function

Function ParsePathOrFile(ByVal strFullFile As String, ByVal fReturnPath As
Integer) As String
'     'Function: ParsePathOrFile
'     'Author:Russell Sinclair
'     'Date: March, 1997
'Purpose:Returns the path or filename (without path) from fi
'     lename
string
On Error GoTo Err_ParsePathOrFile
Dim strPath As String, strFileName As String, lngCurrentPos As Long,
lngLastPos As Long
lngCurrentPos = InStr(strFullFile, "\")
Do Until lngCurrentPos = 0
lngLastPos = lngCurrentPos
lngCurrentPos = InStr(lngCurrentPos + 1, strFullFile, "\")
Loop
If fReturnPath Then
ParsePathOrFile = Trim(Left(strFullFile, lngLastPos - 1))
Else
ParsePathOrFile = Trim(Right(strFullFile, Len(strFullFile) -
lngLastPos))
End If
Exit_ParsePathOrFile:
Exit Function
Err_ParsePathOrFile:
MsgBox Err.Description
Resume Exit_ParsePathOrFile
End Function

'THE FOLLOWING IS THE 32-BIT VERSION OF FATTR.DLL. INSERT THIS TEXT
'INTO A NEW MODULE AND KEEP IT SEPARATELY FROM OTHER MODULES.
'THERE ARE SOME EXTRA FUNCTIONS IN HERE THAT MAY BE OF USE TO YOU.
'MUCH THANKS TO ROGER HARUI
'FOR CREATING THESE FUNCTIONS AND LETTING US ALL USE THEM FREELY.

Option Compare Database
Option Explicit
Public Const ATTR_NORMAL = 0
Public Const ATTR_READONLY = 1
Public Const ATTR_HIDDEN = 2
Public Const ATTR_SYSTEM = 4
Public Const ATTR_LABEL = 8
Public Const ATTR_SUBDIR = 16
Public Const ATTR_ARCHIVE = 32
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternateFileName As String * 14
End Type
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Function GetFileAttr(strFileName As String) As Integer
On Error GoTo Err_GetFileAttr
GetFileAttr = GetAttr(strFileName)
Exit Function
Err_GetFileAttr:
Select Case Err
Case 53:
    GetFileAttr = -2
Case Else
    GetFileAttr = -5
End Select
Exit Function
End Function

Function SetFileAttr(strFileName As String, intAttrib As Integer)
On Error GoTo Err_SetFileAttr
SetAttr strFileName, intAttrib
SetFileAttr = intAttrib
Exit Function
Err_SetFileAttr:
Select Case Err
Case 53:
    SetFileAttr = -2
Case Else
    SetFileAttr = -5
End Select
Exit Function
End Function

Function GetFileSize(strFileName As String)
On Error Resume Next
GetFileSize = FileLen(strFileName)
If Err  0 Then GetFileSize = -1
End Function

Function GetDiskFree(nDrive As Integer)
Dim sec As Long, byt As Long, clu As Long, tot As Long, ret As Long
Dim drv As String
If nDrive = 0 Then nDrive = Asc(Mid(CurDir, 1, 1)) - 64
drv = Chr(nDrive + 64) & ":\"
ret = apiGetDiskFreeSpace(drv, sec, byt, clu, tot)
GetDiskFree = clu * sec * byt
If ret = 0 Then GetDiskFree = -1
End Function

Function GetFileDateTime(strFileName)
On Error Resume Next
GetFileDateTime = FileDateTime(strFileName)
If Err  0 Then GetFileDateTime = -1
End Function

Function SetFileDateTime(strFileName As String, intYear, intMonth, intDay,
intHour, intMinute, intSecond)
Dim lngHandle As Long, ret As Long, cc As Long
Dim st As SYSTEMTIME, ft As FILETIME
lngHandle = apiCreateFile(strFileName, &H40000000, 0, 0, 3, &HA0, 0)
cc = 0
If lngHandle  -1 Then
st.wYear = intYear
st.wMonth = intMonth
st.wDay = intDay
st.wHour = intHour
st.wMinute = intMinute
st.wSecond = intSecond
ret = apiSystemTimeToFileTime(st, ft)
cc = apiSetFileTime(lngHandle, ft, ft, ft)
If cc  0 Then cc = -1
ret = apiCloseHandle(lngHandle)
End If
SetFileDateTime = cc
End Function

Function SetFileDate(strFileName As String, varDate As Variant)
Dim intYear, intMonth, intDay, intHour, intMinute, intSecond
intYear = Year(varDate)
intMonth = Month(varDate)
intDay = Day(varDate)
intHour = Hour(varDate)
intMinute = Minute(varDate)
intSecond = Second(varDate)
SetFileDate = SetFileDateTime(strFileName, intYear, intMonth, intDay,
intHour, intMinute, intSecond)
End Function

Function DosFindFirst(strFileSpec As String, ffStruct As WIN32_FIND_DATA)
As Long
DosFindFirst = apiFindFirstFile(strFileSpec, ffStruct)
End Function

Function DosFindNext(handle As Long, ffStruct As WIN32_FIND_DATA) As Long
Dim ret As Long
DosFindNext = apiFindNextFile(handle, ffStruct)
If DosFindNext = 0 Then
ret = apiFindClose(handle)
DosFindNext = -1
Else
DosFindNext = handle
End If
End Function

Function ConvertDosTime(ftime As FILETIME)
Dim st As SYSTEMTIME, ret As Long
ret = apiFileTimeToSystemTime(ftime, st)
ConvertDosTime = CDate(st.wMonth & "/" & st.wDay & "/" & st.wYear & " "
& st.wHour & ":" & st.wMinute & ":" & st.wSecond)
End Function

'Windows API/Global Declarations for :Repair & Compact database (32 bit)

'Dichiarazioni per la gestione dei Files

'****************************************************************

Declare Function apiGetDiskFreeSpace& Lib "Kernel32" Alias
"GetDiskFreeSpaceA" _
(ByVal lpRootPathName As String, lpSectorsPerCluster As Long, _
lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, _
lpTotalNumberOfClusters As Long)
Declare Function apiFindFirstFile& Lib "Kernel32" Alias "FindFirstFileA" _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA)
Declare Function apiFindNextFile& Lib "Kernel32" Alias "FindNextFileA" _
(ByVal handle As Long, lpFindFileData As WIN32_FIND_DATA)
Declare Function apiFindClose& Lib "Kernel32" Alias "FindClose" (ByVal
handle As Long)
Declare Function apiSetFileTime& Lib "Kernel32" Alias "SetFileTime" _
(ByVal hFile As Long, lpCreationTime As FILETIME, lpLastAccessTime As
FILETIME, _
lpLastWriteTime As FILETIME)
Declare Function apiSystemTimeToFileTime& Lib "Kernel32" Alias
"SystemTimeToFileTime" _
(lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME)
Declare Function apiFileTimeToSystemTime& Lib "Kernel32" Alias
"FileTimeToSystemTime" _
(lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME)
Declare Function apiCreateFile& Lib "Kernel32" Alias "CreateFileA" _
(ByVal strFileName As String, ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDistribution As Long, ByVal dwFlagsAndAttributes As
Long, _
ByVal hTemplateFile As Long)
Declare Function apiCloseHandle& Lib "Kernel32" Alias "CloseHandle" (ByVal
handle As Long)
'****************************************************************

' Name: Repair & Compact database (32 bit)

' Description:Thanks to everyone who has shown an interest i

' n this function. I have

'included the function itself as well as a few of the supporting functions

'it calls. These functions are designed for 32-Bit Access so you may have

'to change a few things to use them in 16-Bit versions. Also, the functions

'included as the 32-Bit version of FATTR.DLL will have to be changed by

'16-Bit users. 16-Bit users can look up the old version at

'http://www.winsite.com . I believe you can find a copy there with the

'necessary instructions. Feel free to distribute this information to anyone

'who needs it.

'"Russell Sinclair"

' By: Newsgroup Posting

'

' Inputs:None

' Returns:None

' Assumes:If you are having problems getting the FATTR.DLL or to work, you can just

'eliminate the if then statement that checks for sufficient disk space.

'However, you do this at your own risk. It can cause you to accidentally

'delete the database you were working with. Also, I have a bit of code at

'the end that reminds users to flag the files (all of the lines with

'fWarnFlag in them) as shareable if they are on a drive >E: (i.e. A netork

'drive). This may not apply to your network (I use netware) so you may wish

'to delete it.Good luck and please feel free to email me if you have any

'questions.

'Russell Sinclair

'Special Projects Analyst

' Side Effects:None

'

'Code provided by Planet Source Code(tm) 'as is', without

' warranties as to performance, fitness, merchantability,

' and any other warranty (whether expressed or implied).

'****************************************************************

Private Type AttachDetails
DomesticName As String
ForeignName As String
Database As String
End Type
Public Function CompactAttachedDatabases() As Boolean
' 'Function: CompactAttachedDatabases

' 'Author:Russell Sinclair

' 'Date: March, 1997

'Purpose:Compacts all databases attached to the current data

' base.

' 'Calls: UniqueArray, GetDiskFree, ParsePathOrFile

' 'Notes: Requires the AttachDetails type.

On Error GoTo Err_CompactAttachedDatabases
Dim atchCompactTables() As AttachDetails, avarDatabases() As Variant,
avarUniqueDatabases() As Variant
Dim wrk As Workspace, db As Database, lngFoundAttached As Long, varX As
Variant, fWarnFlag As Boolean
Dim lngDatabases As Long, lngI As Long
Set db = CurrentDb
lngFoundAttached = 0
' 'Get details for linked Access tables

For lngI = 0 To db.TableDefs.count - 1
If (db.TableDefs(lngI).Attributes And dbAttachedTable) And
(Left(db.TableDefs(lngI).Connect, Len(";DATABASE=")) = ";DATABASE=") Then
lngFoundAttached = lngFoundAttached + 1
ReDim Preserve atchCompactTables(lngFoundAttached - 1)
ReDim Preserve avarDatabases(lngFoundAttached - 1)
atchCompactTables(lngFoundAttached - 1).ForeignName =
db.TableDefs(lngI).SourceTableName
atchCompactTables(lngFoundAttached - 1).DomesticName =
db.TableDefs(lngI).Name
atchCompactTables(lngFoundAttached - 1).Database =
Mid(db.TableDefs(lngI).Connect, Len(";DATABASE=") + 1,
Len(db.TableDefs(lngI).Connect))
avarDatabases(lngFoundAttached - 1) =
Mid(db.TableDefs(lngI).Connect, Len(";DATABASE=") + 1,
Len(db.TableDefs(lngI).Connect))
End If
Next lngI
lngDatabases = UniqueArray(avarUniqueDatabases, avarDatabases,
lngFoundAttached)
For lngI = 0 To lngDatabases - 1
'Ensure that there is enough free space on the drive to comp

' act &

repair
If FileLen(avarUniqueDatabases(lngI)) <
GetDiskFree(Asc(avarUniqueDatabases(lngI)) - 64) Then
RepairDatabase avarUniqueDatabases(lngI)
CompactDatabase avarUniqueDatabases(lngI),
ParsePathOrFile(avarUniqueDatabases(lngI), True) & "\DB1.MDB"
Kill avarUniqueDatabases(lngI)
Name ParsePathOrFile(avarUniqueDatabases(lngI), True) &
"\DB1.MDB" As avarUniqueDatabases(lngI)
CompactAttachedDatabases = True
If fWarnFlag = False Then If (Asc(avarUniqueDatabases(lngI)) -
64) > 5 Then fWarnFlag = True
Else
MsgBox "Insufficient drive space to Repair & Compact database "
& avarUniqueDatabases(lngI) & ". Please free up some space on the " &
Left(avarUniqueDatabases(lngI), 2) & " drive!", vbCritical Or vbOKOnly,
"DBFR"
CompactAttachedDatabases = False
GoTo Exit_CompactAttachedDatabases
End If
Next lngI
For lngI = 0 To lngFoundAttached - 1
db.TableDefs(atchCompactTables(lngI).DomesticName).RefreshLink
Next lngI
If fWarnFlag Then MsgBox "The attached databases reside on the network.
Please exit this program and correct their Flag value to Shareable!",
vbExclamation Or vbOKOnly
Exit_CompactAttachedDatabases:
Exit Function
Err_CompactAttachedDatabases:
MsgBox Err.Description
Resume Exit_CompactAttachedDatabases
End Function

Public Function UniqueArray(ByRef ravarReturnArray() As Variant, ByRef
ravarSourceArray() As Variant, ByVal lngSourceElements As Long) As Long
' 'Function: UniqueArray

' 'Author:Russell Sinclair

' 'Date: March, 1997

'Purpose:Returns an array with unique values from an array w

' ith multiple

' 'instances of values.

On Error GoTo Err_UniqueArray
Dim lngReturnElements As Long, lngI As Long, varCurrentValue As
Variant, lngJ As Long
Dim lngCurrentIndex As Long, fNoMatch As Boolean
lngReturnElements = 0
For lngI = 0 To lngSourceElements - 1
varCurrentValue = ravarSourceArray(lngI)
fNoMatch = True
lngJ = 0
Do While fNoMatch And lngJ <= lngReturnElements - 1
If ravarReturnArray(lngJ) = varCurrentValue Then fNoMatch =
False
lngJ = lngJ + 1
Loop
If fNoMatch Then
ReDim Preserve ravarReturnArray(lngReturnElements)
ravarReturnArray(lngReturnElements) = varCurrentValue
lngReturnElements = lngReturnElements + 1
End If
Next lngI
UniqueArray = lngReturnElements
Exit_UniqueArray:
Exit Function
Err_UniqueArray:
MsgBox Err.Description
Resume Exit_UniqueArray
End Function

Function ParsePathOrFile(ByVal strFullFile As String, ByVal fReturnPath As
Integer) As String
' 'Function: ParsePathOrFile

' 'Author:Russell Sinclair

' 'Date: March, 1997

'Purpose:Returns the path or filename (without path) from fi

' lename

string
On Error GoTo Err_ParsePathOrFile
Dim strPath As String, strFileName As String, lngCurrentPos As Long,
lngLastPos As Long
lngCurrentPos = InStr(strFullFile, "\")
Do Until lngCurrentPos = 0
lngLastPos = lngCurrentPos
lngCurrentPos = InStr(lngCurrentPos + 1, strFullFile, "\")
Loop
If fReturnPath Then
ParsePathOrFile = Trim(Left(strFullFile, lngLastPos - 1))
Else
ParsePathOrFile = Trim(Right(strFullFile, Len(strFullFile) -
lngLastPos))
End If
Exit_ParsePathOrFile:
Exit Function
Err_ParsePathOrFile:
MsgBox Err.Description
Resume Exit_ParsePathOrFile
End Function

'THE FOLLOWING IS THE 32-BIT VERSION OF FATTR.DLL. INSERT THIS TEXT

'INTO A NEW MODULE AND KEEP IT SEPARATELY FROM OTHER MODULES.

'THERE ARE SOME EXTRA FUNCTIONS IN HERE THAT MAY BE OF USE TO YOU.

'MUCH THANKS TO ROGER HARUI

'FOR CREATING THESE FUNCTIONS AND LETTING US ALL USE THEM FREELY.

Option Compare Database
Option Explicit
Public Const ATTR_NORMAL = 0
Public Const ATTR_READONLY = 1
Public Const ATTR_HIDDEN = 2
Public Const ATTR_SYSTEM = 4
Public Const ATTR_LABEL = 8
Public Const ATTR_SUBDIR = 16
Public Const ATTR_ARCHIVE = 32
Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternateFileName As String * 14
End Type
Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Function GetFileAttr(strFileName As String) As Integer
On Error GoTo Err_GetFileAttr
GetFileAttr = GetAttr(strFileName)
Exit Function
Err_GetFileAttr:
Select Case Err
Case 53:
GetFileAttr = -2
Case Else
GetFileAttr = -5
End Select
Exit Function
End Function

Function SetFileAttr(strFileName As String, intAttrib As Integer)
On Error GoTo Err_SetFileAttr
SetAttr strFileName, intAttrib
SetFileAttr = intAttrib
Exit Function
Err_SetFileAttr:
Select Case Err
Case 53:
SetFileAttr = -2
Case Else
SetFileAttr = -5
End Select
Exit Function
End Function

Function GetFileSize(strFileName As String)
On Error Resume Next
GetFileSize = FileLen(strFileName)
If Err 0 Then GetFileSize = -1
End Function

Function GetDiskFree(nDrive As Integer)
Dim sec As Long, byt As Long, clu As Long, tot As Long, ret As Long
Dim drv As String
If nDrive = 0 Then nDrive = Asc(Mid(CurDir, 1, 1)) - 64
drv = Chr(nDrive + 64) & ":\"
ret = apiGetDiskFreeSpace(drv, sec, byt, clu, tot)
GetDiskFree = clu * sec * byt
If ret = 0 Then GetDiskFree = -1
End Function

Function GetFileDateTime(strFileName)
On Error Resume Next
GetFileDateTime = FileDateTime(strFileName)
If Err 0 Then GetFileDateTime = -1
End Function

Function SetFileDateTime(strFileName As String, intYear, intMonth, intDay,
intHour, intMinute, intSecond)
Dim lngHandle As Long, ret As Long, cc As Long
Dim st As SYSTEMTIME, ft As FILETIME
lngHandle = apiCreateFile(strFileName, &H40000000, 0, 0, 3, &HA0, 0)
cc = 0
If lngHandle -1 Then
st.wYear = intYear
st.wMonth = intMonth
st.wDay = intDay
st.wHour = intHour
st.wMinute = intMinute
st.wSecond = intSecond
ret = apiSystemTimeToFileTime(st, ft)
cc = apiSetFileTime(lngHandle, ft, ft, ft)
If cc 0 Then cc = -1
ret = apiCloseHandle(lngHandle)
End If
SetFileDateTime = cc
End Function

Function SetFileDate(strFileName As String, varDate As Variant)
Dim intYear, intMonth, intDay, intHour, intMinute, intSecond
intYear = Year(varDate)
intMonth = Month(varDate)
intDay = Day(varDate)
intHour = Hour(varDate)
intMinute = Minute(varDate)
intSecond = Second(varDate)
SetFileDate = SetFileDateTime(strFileName, intYear, intMonth, intDay,
intHour, intMinute, intSecond)
End Function

Function DosFindFirst(strFileSpec As String, ffStruct As WIN32_FIND_DATA)
As Long
DosFindFirst = apiFindFirstFile(strFileSpec, ffStruct)
End Function

Function DosFindNext(handle As Long, ffStruct As WIN32_FIND_DATA) As Long
Dim ret As Long
DosFindNext = apiFindNextFile(handle, ffStruct)
If DosFindNext = 0 Then
ret = apiFindClose(handle)
DosFindNext = -1
Else
DosFindNext = handle
End If
End Function

Function ConvertDosTime(ftime As FILETIME)
Dim st As SYSTEMTIME, ret As Long
ret = apiFileTimeToSystemTime(ftime, st)
ConvertDosTime = CDate(st.wMonth & "/" & st.wDay & "/" & st.wYear & " "
& st.wHour & ":" & st.wMinute & ":" & st.wSecond)
End Function