home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
bp_6_93
/
vbwin
/
vbaccess
/
glob.txt
< prev
next >
Wrap
Text File
|
1995-02-26
|
4KB
|
159 lines
Option Explicit
'globale Konstanten und Variable
Global Const DEFAULT = 0
Global Const HOURGLASS = 11
Global Const MB_OK = 0
Global Const MB_YESNO = 4 ' Yes and No buttons
Global Const IDYES = 6 ' Yes button pressed
Global Const MB_ICONSTOP = 16
Global Const MB_DEFBUTTON2 = 256 ' Second button is default
Global Const ERR_FILENOTFOUND = 53
Global Const MODAL = 1
'Konstanten zur Unterscheidung der Aktionen
'Konstante wird aus dem Tag frmInfo ausgelesen
Global Const INFO_COMPACT = 0
Global Const INFO_REPAIR = 1
Global NL As String
Global Datum As String
Global sMdb As String
Global sMdb_pur As String
Global db1 As Database
Global sVNewFile As String
Global sVOldFile As String
'Datenbank Version
Global iVersion As Integer
Global tSettings As table
Sub CenterForm (frmX As Form)
frmX.Top = Screen.Height / 2 - frmX.Height / 2
frmX.Left = Screen.Width / 2 - frmX.Width / 2
End Sub
Function Date2Julian& (DAT As String)
'erwartet Short oder longDate
Dim iMonth As Integer, iDay As Integer, iYear As Integer
Dim lTa As Long, lTb As Long, lTc As Long
iMonth = Val(Mid$(DAT, 4, 2))
iDay = Val(Mid$(DAT, 1, 2))
'new 8.1.94: unterscheidet long an short Version
Select Case Len(DAT)
Case 8 'short Date
iYear = Year2BigYear%(Val(Mid$(DAT, 7, 2)))
Case 10 'long Date
iYear = Val(Right$(DAT, 4))
End Select
If iMonth > 2 Then
iMonth = iMonth - 3
Else
iMonth = iMonth + 9
iYear = iYear - 1
End If
lTa = 146097 * (iYear \ 100) \ 4
lTb = 1461& * (iYear Mod 100) \ 4
lTc = (153 * iMonth + 2) \ 5 + iDay + 1721119
Date2Julian& = lTa + lTb + lTc
End Function
Function DaysBetweenDates& (DAT1 As String, DAT2 As String)
DaysBetweenDates& = Abs(Date2Julian&(DAT1) - Date2Julian&(DAT2))
End Function
Function MdbCheck () As Integer
Dim it As Integer
Dim lmdb As Long
Dim sMsg As String
Dim iDgDef As Integer
Dim iResponse As Integer
Dim sTitel As String
Set tSettings = db1.OpenTable("Settings")
If tSettings!MdbVersion <> iVersion Then
tSettings.Close
MdbCheck = True
Exit Function
End If
If DaysBetweenDates&((tSettings!LastReorg), Datum) > 14 Then
sTitel = "Verdichtung"
sMsg = "Datenbank ist seit mehr als 14 Tagen nicht mehr komprimiert worden." + NL
sMsg = sMsg + "Wollen Sie jetzt verdichten ?" + NL
iDgDef = MB_YESNO + MB_ICONSTOP + MB_DEFBUTTON2
iResponse = MsgBox(sMsg, iDgDef, sTitel)
If iResponse = IDYES Then
tSettings.Close
If mdbVerdichten() Then
Set tSettings = db1.OpenTable("Settings")
tSettings.Edit
tSettings!LastReorg = Datum
tSettings.Update
End If
End If
End If
tSettings.Close
End Function
Function mdbVerdichten () As Integer
Dim sTitel As String
Dim sMsg As String
Dim iDgDef As Integer
Dim iResponse As Integer
Screen.MousePointer = HOURGLASS
On Error GoTo Verdicht_Errorhandler
db1.Close
Set db1 = OpenDatabase(sMdb, True)
db1.Close
sVNewFile = sMdb_pur + ".mdb"
sVOldFile = sMdb_pur + ".old"
Kill sVOldFile
Name sVNewFile As sVOldFile
Load frmInfo
frmInfo.Tag = INFO_COMPACT 'Verdichten
frmInfo.Show MODAL
Set frmInfo = Nothing
Set db1 = OpenDatabase(sMdb)
Screen.MousePointer = DEFAULT
mdbVerdichten = True
Exit Function
Verdicht_Errorhandler:
If Err = 3051 Or Err = 3000 Then
sTitel = "Verdichtung fehlgeschlagen !"
sMsg = "Datenbank kann nicht verdichtet werden, da sie von einem anderen Benutzer bereits ge÷ffnet ist !" + NL
sMsg = sMsg + "Zur Verdichtung alle Zugriffe beenden und Verdichtung nochmals starten !"
iDgDef = MB_OK + MB_ICONSTOP
iResponse = MsgBox(sMsg, iDgDef, sTitel)
Set db1 = OpenDatabase("Stamm.mdb")
Screen.MousePointer = DEFAULT
Exit Function
End If
If Err = ERR_FILENOTFOUND Then
Resume Next
End If
Resume Next
End Function
Function Year2BigYear% (iDay As Integer)
'Korrektur 1900 bzw 2000
Year2BigYear% = IIf(iDay < 50, iDay + 2000, iDay + 1900)
End Function