VBA生产SQL文

Public strCurDir As String
Public strDBId As String
Private Declare Function GetCurrentDirectory Lib "kernel32" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
'
' table sql script
'
Sub CreateTableScript(strTableName As String)
    Dim iStartCellCol As Integer
    Dim iStartCellRow As Integer
    Dim iEndCellCol As Integer
    Dim iEndCellRow As Integer
    Dim strCellValue As String
    Dim fs, myfile As Object
    Dim strOneRow As String
    Dim strScript As String
   
    Dim FieldName As String
    Dim FieldId As String
    Dim FieldType As String
    Dim FieldLength As String
    Dim IsKey As String
    Dim NotNull As String
    Dim Index As String
    Dim strTableID As String
   
    Dim strPrimaryKey() As String
    Dim iPrimaryKeyCnt As Integer
    Dim strIndex() As String
    Dim iIndexCnt As Integer
   
    iStartCellCol = 2
    iStartCellRow = 5
    iEndCellCol = 9
    iEndCellRow = 10000
   
    Worksheets(strTableName).Activate
    strTableID = ActiveSheet.Cells(2, 3)

    If strCurDir <> "" Then
        strCurDir = strCurDir & "//"
    Else
        strCurDir = "C://"
    End If

    Set fs = CreateObject("Scripting.FileSystemObject")
    Set myfile = fs.CreateTextFile(strCurDir & strTableID & ".sql")
    
    strScript = "DROP TABLE IF EXISTS " & strTableID & ";"
   
    myfile.WriteLine (strScript)
    myfile.WriteLine ("CREATE TABLE " & strTableID & "(")

    Call WriteFile(strScript)
    Call WriteFile("CREATE TABLE " & strTableID & "(")

    ReDim strPrimaryKey(0)
    ReDim strIndex(0)
    iPrimaryKeyCnt = 0
   
    For i = iStartCellRow To iEndCellRow
   
        strOneRow = ""
        strCellValue = ActiveSheet.Cells(i, 1)
       
        If strCellValue = "" Then
           
            strOneRow = strOneRow & " primary key("
           
            For j = 0 To UBound(strPrimaryKey) - 1
           
                If (j = UBound(strPrimaryKey) - 1) Then
               
                    strOneRow = strOneRow & strPrimaryKey(j)
                Else
               
                    strOneRow = strOneRow & strPrimaryKey(j) & ","
                End If
            Next
           
            strOneRow = strOneRow & ")"
           
            myfile.WriteLine (strOneRow)
           
            Call WriteFile(strOneRow)
            Exit For
        End If
           
        FieldName = Trim(ActiveSheet.Cells(i, 2))
        FieldId = Trim(ActiveSheet.Cells(i, 3))
        FieldType = Trim(ActiveSheet.Cells(i, 4))
        FieldLength = Trim(ActiveSheet.Cells(i, 5))
        IsKey = Trim(ActiveSheet.Cells(i, 6))
        NotNull = Trim(ActiveSheet.Cells(i, 7))
        Index = Trim(ActiveSheet.Cells(i, 8))
   
        strOneRow = "    " & FieldId
        If (FieldType = "varchar") Then
            strOneRow = strOneRow & " " & FieldType & "(" & FieldLength & ")"
        ElseIf (FieldType = "int") Then
            strOneRow = strOneRow & " " & FieldType & "(" & FieldLength & ")"
        ElseIf (FieldType = "float") Then
            strOneRow = strOneRow & " "
        ElseIf (FieldType = "money") Then
            strOneRow = strOneRow & " "
        ElseIf (FieldType = "numeric") Then
            strOneRow = strOneRow & " " & FieldType & "(" & FieldLength & ")"
        ElseIf (FieldType = "bigint") Then
            strOneRow = strOneRow & " "
        ElseIf (FieldType = "datetime") Then
            strOneRow = strOneRow & " "
        Else
            strOneRow = strOneRow & " " & FieldType
        End If
       
        If (NotNull = "1") Then
            strOneRow = strOneRow & " not null, "
        Else
            strOneRow = strOneRow & ", "
        End If
       
        strOneRow = strOneRow & "# " & FieldName
       
        If (IsKey = "1") Then
            strPrimaryKey(iPrimaryKeyCnt) = FieldId
            iPrimaryKeyCnt = iPrimaryKeyCnt + 1
            ReDim Preserve strPrimaryKey(iPrimaryKeyCnt)
        End If
       
        If (Index = "1") Then
            strIndex(iIndexCnt) = FieldId
            iIndexCnt = iIndexCnt + 1
            ReDim Preserve strIndex(iIndexCnt)
        End If
       
       
        myfile.WriteLine (strOneRow)
        Call WriteFile(strOneRow)
    Next
    myfile.WriteLine (")")
    myfile.WriteLine ("")
   
    Call WriteFile(")")
    Call WriteFile("")
   
   
    'myfile.WriteLine ("GRANT SELECT,INSERT, UPDATE, DELETE")
    'Call WriteFile("GRANT SELECT,INSERT, UPDATE, DELETE")
   
    'myfile.WriteLine ("ON [dbo].[" & strTableID & "]")
    'Call WriteFile("ON [dbo].[" & strTableID & "]")
   
    'myfile.WriteLine ("TO " & strDBId)
    'Call WriteFile("TO " & strDBId)
   
    'myfile.WriteLine ("GO")
    'Call WriteFile("GO")
   
    myfile.WriteLine (";")
    Call WriteFile(";")
   
    For j = 0 To UBound(strIndex) - 1
        strOneRow = "create index idx_" & strTableID & "_" & strIndex(j) & " on " & strTableID & " (" & strIndex(j) & ");"
        myfile.WriteLine (strOneRow)
        Call WriteFile(strOneRow)
    Next

    myfile.Close
End Sub

 

Dim fs, logFile, myfile As Object

Sub OpenLog(filepath As String)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set logFile = fs.CreateTextFile(filepath & "DataImport.log")
End Sub

Sub WriteLog(strOneRow As String)
    logFile.WriteLine (strOneRow)
End Sub

Sub CloseLog()
    logFile.Close
End Sub

Sub OpenFile(filepath As String)
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set myfile = fs.CreateTextFile(filepath)
End Sub

Sub WriteFile(strOneRow As String)
    myfile.WriteLine (strOneRow)
End Sub

Sub CloseFile()
    myfile.Close
End Sub

Function CheckError(obj As Object) As String
    If (IsError(obj)) Then
        CheckError = ""
    Else
        CheckError = CStr(obj)
    End If
End Function

Function ReplaceBlank(str As String) As String
    str = Replace(str, " ", "")
    str = Replace(str, "@", "")
   
    ReplaceBlank = str
End Function

Sub GetFilesByFolder(folderspec As String, arrFiles() As String)
    Dim fs, f, f1, fc
   
    Dim arrFolders() As String
    Dim strWork As String
    Dim iFolderIndex As Integer
    Dim bFlg As Boolean
    Dim i As Integer
    Dim strFileType As String
   
    ReDim arrFiles(0)
    ReDim arrFolders(0)
    iFolderIndex = 0
    bFlg = True
    i = 0
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.SubFolders
       
    For Each f1 In fc
        arrFolders(UBound(arrFolders)) = f1.Path
        ReDim Preserve arrFolders(UBound(arrFolders) + 1)
    Next

    Do While bFlg
        strWork = arrFolders(iFolderIndex)
        If (strWork <> "") Then
            Set f = fs.GetFolder(strWork)
               
            Set fc = f.SubFolders
            For Each f1 In fc
                arrFolders(UBound(arrFolders)) = f1.Path
    '            Debug.Print f1.Path
               
                ReDim Preserve arrFolders(UBound(arrFolders) + 1)
            Next
           
            iFolderIndex = iFolderIndex + 1
'            If (iFolderIndex = UBound(arrFolders) - 1) Then
'                bFlg = False
'            End If
        Else
            bFlg = False
        End If
    Loop
   
    For i = 0 To UBound(arrFolders) - 1
        strWork = arrFolders(i)
       
        Set f = fs.GetFolder(strWork)
        Set fc = f.Files
        For Each f1 In fc
            strFileType = f1.Path
            If Right(strFileType, Len(".xls")) = ".xls" Then
           
                arrFiles(UBound(arrFiles)) = f1.Path
               
               
                ReDim Preserve arrFiles(UBound(arrFiles) + 1)
            End If

        Next

    Next
   
End Sub

'
' Null to empty
'
Function NullToEmpty(str As String) As String
    NullToEmpty = str
   
    If IsNull(str) Then
        NullToEmpty = ""
    End If
   
End Function

Function GetCurDir() As String
    Dim MyPath As String
   
    MyPath = CurDir("e")
    MyPath = MyPath & "//"

    GetCurDir = MyPath
End Function