mdeclare.bas

用于生产企业设备备件管理系统

Attribute VB_Name = "MDeclare"
Option Explicit

Type CAppInformation
    UserName As String
    UserPW As String
    UserOP As String
    BackUpPath As String
    DataPath As String
End Type

Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Public Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public MyAppInfo As CAppInformation
Public StrConn As String
Public MaxPageSize As Long

Public Function GetTempDirectory() As String
Dim tempPath As String, sLen As Integer
    tempPath = String(255, 0)
    sLen = GetTempPath(256, tempPath)
    tempPath = Left(tempPath, sLen)
    GetTempDirectory = tempPath
End Function

Public Sub CompactJetDatabase()
On Error GoTo ErrFlag
Dim strTempFile As String

    CopyFile MyAppInfo.DataPath, MyAppInfo.BackUpPath & "\data-" & Date & ".mdb", 0
    
    strTempFile = GetTempDirectory & "temp.mdb"
    DBEngine.CompactDatabase MyAppInfo.DataPath, strTempFile
    
    Kill MyAppInfo.DataPath
   
    CopyFile strTempFile, MyAppInfo.DataPath, 0
    
    Kill strTempFile
    MsgBox "压缩数据库成功", vbOKOnly + vbInformation
    
    Exit Sub

ErrFlag:
    MsgBox "[压缩数据库]" & Err.Description, vbOKOnly + vbInformation
    
End Sub

Public Sub CreateNewDirectory(NewDirectory As String)
Dim sDirTest As String
Dim SecAttrib As SECURITY_ATTRIBUTES
Dim bSuccess As Boolean
Dim sPath As String
Dim iCounter As Integer
Dim sTempDir As String
Dim iFlag As Integer
    iFlag = 0
    sPath = NewDirectory
    
    If Right(sPath, Len(sPath)) <> "\" Then
        sPath = sPath & "\"
    End If
    
    iCounter = 1
    Do Until InStr(iCounter, sPath, "\") = 0
        iCounter = InStr(iCounter, sPath, "\")
        sTempDir = Left(sPath, iCounter)
        sDirTest = Dir(sTempDir)
        iCounter = iCounter + 1
        
        SecAttrib.lpSecurityDescriptor = &O0
        SecAttrib.bInheritHandle = False
        SecAttrib.nLength = Len(SecAttrib)
        bSuccess = CreateDirectory(sTempDir, SecAttrib)
    Loop
End Sub

Public Function CheckData(StrTemp As String, strCol As String, Optional CheckNumeric As Boolean = False) As Boolean
On Error GoTo ErrFlag
    CheckData = False
    If Len(Trim(StrTemp)) <= 0 Then
        MsgBox "[" & strCol & "]栏位必须输入资料"
        Exit Function
    End If
    
    If CheckNumeric = True Then
        If IsNumeric(StrTemp) = False Then
            MsgBox "[" & strCol & "]栏位为数字"
            Exit Function
        End If
    End If
    
    CheckData = True
    Exit Function
    
ErrFlag:
    MsgBox "[验证错误]" + Err.Description, vbOKOnly + vbCritical
End Function