mdlgeneral.bas

来自「这是一个实际的工程中所用的源程序」· BAS 代码 · 共 75 行

Attribute VB_Name = "mdlGeneral"
Option Explicit
'Task: Create a multi-level directory structure using CreateDirectory API call

Private Type SECURITY_ATTRIBUTES

    nLength As Long
    lpSecurityDescriptor As Long
    bInheritHandle As Long
End Type

Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long



'use the following subroutine
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
    iCounter = 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
        'create directory
        SecAttrib.lpSecurityDescriptor = &O0
        SecAttrib.bInheritHandle = False
        SecAttrib.nLength = Len(SecAttrib)
        bSuccess = CreateDirectory(sTempDir, SecAttrib)
    Loop

End Sub

Public Function meStateChange(ByVal vPreState As eEditState, ByVal bChanged As Boolean) _
                            As eEditState
                            
    Dim s As eEditState
    s = vPreState
    If bChanged Then
        If s = meEditNormal Then
                 s = meEditEnabled
        Else
                 s = meEditFinished
        End If
    Else
            s = meEditNormal
    End If
    meStateChange = s
End Function
Public Sub meAutoCreateTableDef_tblQX()
    Static EditState As eEditState '
    Dim bCopyEnabled As Boolean
    On Error Resume Next
  '*****
     bCopyEnabled = CBool(Weekday(Date) = vbSunday)
       EditState = meStateChange(EditState, bCopyEnabled)
    If EditState = meEditEnabled Then
    '备份数据库
         
    End If
End Sub