clscreatedb.cls

一个用VB写的财务软件源码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsCreateDB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private m_Scripts As New VBA.Collection
Private WithEvents m_Init As TableFileForXML.clsTBinfo
Attribute m_Init.VB_VarHelpID = -1
'进度
Public Event Propross(ByVal Percent As Single, _
ByRef Cancel As Boolean)
Public Event ExecuteCount(ByVal Count As Long)
Private m_cnn As ADODB.Connection
Private m_Year As String
Dim oFileSystemLOG As New FileSystemObject
Dim oTextStreamLOG As TextStream
Public Property Let cnnVirtual(ByVal vNewValue As ADODB.Connection)
Set m_cnn = vNewValue
End Property
Public Property Let sYear(ByVal vNewValue As String)
m_Year = vNewValue
End Property

Public Sub Append(ByVal o As clsScript)
m_Scripts.Add o
End Sub
Public Sub Delete(ByVal index As Integer)
If m_Scripts.Count >= index And index > 0 Then
    m_Scripts.Remove index
End If
End Sub

Public Function Item(ByVal index As Integer) As clsScript
If m_Scripts.Count >= index And index > 0 Then
    Set Item = m_Scripts.Item(index)
End If
End Function

Public Function Count() As Integer
Count = m_Scripts.Count
End Function

'执行
Public Sub DoExecute(Optional ByVal bIsNb As Boolean = False, Optional ByVal bValidInstr As Boolean = False)
Dim i As Integer
Dim Cancel As Boolean
i = 1
Cancel = False
While i <= m_Scripts.Count And Cancel = False
    If bIsNb Then
       ExecuteScriptNb m_Scripts.Item(i), bValidInstr
    Else
       ExecuteScript m_Scripts.Item(i)
    End If
    RaiseEvent Propross(i / m_Scripts.Count, Cancel)
    i = i + 1
Wend
End Sub
'单步执行脚本
Private Sub ExecuteScript(ScriptFile As clsScript)
Dim cmd As ADODB.Command
Dim oFileSystem As New FileSystemObject
Dim oTextStream As TextStream
Dim pTextStream As TextStream
Dim ReadScriptSql As String
Dim sqlFile As String
Dim pos As Long
Dim nextPos As Long
Set cmd = New ADODB.Command
pos = 1
Select Case ScriptFile.usFileType
Case "Sql"
     cmd.ActiveConnection = m_cnn
     cmd.CommandType = adCmdText
     Set oTextStream = oFileSystem.OpenTextFile(ScriptFile.usScriptFilename)
     Set pTextStream = oFileSystem.OpenTextFile(ScriptFile.usScriptFilename)
     sqlFile = pTextStream.ReadAll
           Do Until pos >= Len(sqlFile)
                nextPos = InStr(pos, sqlFile, ";") + 1
                If nextPos > pos Then
                    ReadScriptSql = oTextStream.Read(nextPos - pos)
                    ReadScriptSql = Replace(ReadScriptSql, "<<YEAR>>", m_Year)
                    cmd.CommandText = Left(ReadScriptSql, Len(ReadScriptSql) - 1)
                    On Error Resume Next
                    cmd.Execute
                        If Err.Number > 0 Then
                           WriteLog "ErrNum=" & Err.Number
                           WriteLog "ErrDes=" & Err.Description
                           WriteLog "Sql=" & cmd.CommandText
                        End If
                    ReadScriptSql = ""
                Else
                    Exit Do
                End If
                pos = nextPos
           Loop
Case "Xml"
    Dim g As GlobalInterface.clsGlobal
    Set g = New GlobalInterface.clsGlobal
    g.cnnMain = m_cnn
    g.g_FLAT = g_FLAT
    m_Init.iGlo = g
    m_Init.InsertFromSoap ScriptFile.usScriptFilename, False
End Select
End Sub
'单步执行脚本
'bvalidInstr　插入语句是否有效
Private Sub ExecuteScriptNb(ScriptFile As clsScript, Optional ByVal bValidInstr As Boolean = False)
Dim cmd As ADODB.Command
Dim oFileSystem As New FileSystemObject
Dim oTextStream As TextStream
Dim pTextStream As TextStream
Dim ReadScriptSql As String
Dim sqlFile As String
Dim pos As Long
Dim Tmp As String
Dim nextPos As Long
Set cmd = New ADODB.Command
pos = 1
Select Case ScriptFile.usFileType
Case "Sql"
     cmd.ActiveConnection = m_cnn
     cmd.CommandType = adCmdText
     Set oTextStream = oFileSystem.OpenTextFile(ScriptFile.usScriptFilename)
         Set pTextStream = oFileSystem.OpenTextFile(ScriptFile.usScriptFilename)
        sqlFile = pTextStream.ReadAll
           Do Until pos >= Len(sqlFile)
                nextPos = InStr(pos, sqlFile, ";") + 1
                If nextPos > pos Then
                    ReadScriptSql = oTextStream.Read(nextPos - pos)
                    If InStr(1, ReadScriptSql, "<<YEAR>>", vbTextCompare) > 0 And _
                      (InStr(1, UCase$(Replace(ReadScriptSql, " ", "")), "INSERTINTO", vbTextCompare) = 0 Or bValidInstr) Then
                        ReadScriptSql = Replace(ReadScriptSql, "<<YEAR>>", m_Year)
                        ReadScriptSql = Replace(ReadScriptSql, "<<PREYEAR>>", m_Year - 1)
                        If g_FLAT = "SQL" Then
                            ReadScriptSql = UCase$(ReadScriptSql)
                            ReadScriptSql = Replace(ReadScriptSql, "CONSTRAINT [DF_", "CONSTRAINT [DF_" & m_Year & "_")
                            ReadScriptSql = Replace(ReadScriptSql, "CONSTRAINT [PK_", "CONSTRAINT [PK_" & m_Year & "_")
                        End If
                        cmd.CommandText = Left(ReadScriptSql, Len(ReadScriptSql) - 1)
                        On Error Resume Next
                        cmd.Execute
                        If Err.Number <> 0 Then
                           WriteLog "ErrNum=" & Err.Number
                           WriteLog "ErrDes=" & Err.Description
                           WriteLog "ScFile=" & ScriptFile.usScriptFilename
                           WriteLog "Sql=" & cmd.CommandText
                        End If
                    End If
                    ReadScriptSql = ""
                Else
                    Exit Do
                End If
                pos = nextPos
           Loop
Case "Xml"
    Dim g As GlobalInterface.clsGlobal
    Set g = New GlobalInterface.clsGlobal
    g.cnnMain = m_cnn
    g.g_FLAT = g_FLAT
    m_Init.iGlo = g
    m_Init.InsertFromSoap ScriptFile.usScriptFilename, False
End Select
End Sub
Public Property Get uInitContent() As TableFileForXML.clsTBinfo
Set uInitContent = m_Init
End Property

Public Property Let uInitContent(ByVal vNewValue As TableFileForXML.clsTBinfo)
Set m_Init = vNewValue
End Property

Private Sub Class_Initialize()
If Dir(App.Path & "\CREATENBERR.LOG") = "" Then
   Set oTextStreamLOG = oFileSystemLOG.OpenTextFile(App.Path & "\CREATENBERR.LOG", ForWriting, True)
Else
  Set oTextStreamLOG = oFileSystemLOG.OpenTextFile(App.Path & "\CREATENBERR.LOG", ForAppending, False)
End If
WriteLog ""
WriteLog ""
WriteLog ""
WriteLog "//*******************************************************************************//"
WriteLog "// Datebase:" & g_FLAT
WriteLog "// Operotion Begin Time:" & Date & " " & Time
End Sub

Private Sub Class_Terminate()
WriteLog "//*********************   Operotion End    *************************************//"
oTextStreamLOG.Close
Set oTextStreamLOG = Nothing
Set oFileSystemLOG = Nothing
End Sub

Private Sub m_Init_FinishNumber(ByVal l As Long)
RaiseEvent ExecuteCount(l)
End Sub
Private Sub WriteLog(ByRef sMsg As String)
oTextStreamLOG.WriteLine sMsg
End Sub