Excel 应用07_自动生成Table和data作成

本文主要是介绍Excel 应用07_自动生成Table和data作成_VBA，希望对大家解决编程问题提供一定的参考价值，需要的开发者们随着小编来一起学习吧！

SelectModule

Const SqlServerRow = 2 Sub AllSheetsMakeCreateSQL() If ThisWorkbook.Worksheets("設定・作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeCreateSQL Else SQL2000.AllSheetsMakeCreateSQL End If End Sub Sub AllSheetsMakeSP() If ThisWorkbook.Worksheets("バッチ作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeSP Else SQL2000.AllSheetsMakeSP End If End Sub Sub AllSheetsMakeBCP() If ThisWorkbook.Worksheets("BCP作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeBCP Else SQL2000.AllSheetsMakeBCP End If End S

SQL2000

'CreateTable用　固定値 Const CreateTableBat = "CreateTable.bat" Const CreateIndexBat = "CreateIndex.bat" Const CreateSPBat = "CreateSP.bat" Const CreateBCPBat = "CreateBCP.bat" Const SheetNameIgnore = "設定・作成" Const SheetNameHIF = "ホストIF" Const SheetNameStartRow = 14 Const SheetNameStartCol = 1 Const DbTypeRow = 2 Const InPathRow = 3 Const FilePathRow = 4 Const SuffixRow = 4 Const IdxFilePathRow = 5 Const DbNameRow = 7 Const DbUserRow = 8 Const DbPswdRow = 9 Const DbServerRow = 10 Const BatLogRow = 11 '各テーブル定義書用　固定値 Const SQLCreateRow = 20 '項目開始行 Const ItemNameCol = 2 '項目名カラム Const ItemIDCol = 6 '項目IDカラム Const ItemAttributeCol = 10 '項目属性カラム Const ItemLengthCol = 12 '項目レングスカラム Const ItemScaleCol = 13 '項目小数点レングスカラム Const ItemPKeyCol = 15 '主キーカラム Const ItemNotNullCol = 16 'Not Null制約カラム Const ItemDefaultCol = 17 '初期値カラム Const TableNameRow = 4 Const TableNameCol = 5 Const FileGroupRow = 5 Const FileGroupCol = 14 'ブック名チェック Function BookCheck(pathName As String, bookName As String) As Integer On Error GoTo BookCheckError Dim sheetName As String BookCheck = 0 If bookName = "CreateSQL.xls" Then BookCheck = 1 Exit Function End If If InStr(1, bookName, ".xls") = 0 Then BookCheck = 1 Exit Function End If 'sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) 'Application.Workbooks.Open pathName + bookName, , True 'Workbooks(bookName).Worksheets(sheetName).Activate 'Workbooks(bookName).Close False Exit Function BookCheckError: If (Err = 9) Then BookCheck = 1 Workbooks(bookName).Close Exit Function End If End Function 'ブック名チェック Function BookCheck2(pathName As String, bookName As String, suffix As String) As Integer On Error GoTo BookCheck2Error Dim sheetName As String BookCheck2 = 0 If InStr(1, UCase(bookName), suffix) = 0 Then BookCheck2 = 1 Exit Function End If Exit Function BookCheck2Error: If (Err = 9) Then BookCheck2 = 1 Exit Function End If End Function 'ブック名チェック Function BookCheck3(pathName As String, bookName As String, pos As Integer) As Integer On Error GoTo BookCheck3Error Dim sheetName As String BookCheck3 = 0 If bookName = "CreateSQL.xls" Then BookCheck3 = 1 Exit Function End If If InStr(1, bookName, ".xls") = 0 Then BookCheck3 = 1 Exit Function End If sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open pathName + bookName, , True Workbooks(bookName).Worksheets(sheetName).Activate If (Worksheets(sheetName).Cells(18, 27) <> "ホストインターフェイス情報") Then BookCheck3 = 1 Else If (Worksheets(sheetName).Cells(8, 16) <> "ホストIF情報") Then Workbooks("CreateSQL.xls").Worksheets("ホストIF").Cells(pos, 2) = "旧フォーマットのレイアウトです、削除フラグは各テーブルレイアウトに定義してください" End If End If Workbooks(bookName).Close False Exit Function BookCheck3Error: If (Err = 9) Then BookCheck3 = 1 Workbooks(bookName).Close Exit Function End If End Function 'BCP検索 Sub BCPLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("BCP作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("BCP作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("BCP作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub 'SP検索 Sub SPLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("バッチ作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub '実行！！ Sub AllSheetsMakeBCP() createTable = False LogPath = Worksheets("BCP作成").Cells(BatLogRow, 2) FilePath = Worksheets("BCP作成").Cells(InPathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets("BCP作成").Cells(FilePathRow, 2).Select Exit Sub End If End If If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If S = 0 SQLSheetName = Worksheets("BCP作成").Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" pos = InStrRev(SQLSheetName, "/") bookName = Mid(Mid(SQLSheetName, pos + 1), 1, Len(Mid(SQLSheetName, pos + 1)) - 4) If (S = 0) Then Filename = FilePath & "/" & CreateBCPBat Open Filename For Output As #2 Print #2, "echo BCP作成 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets("BCP作成").Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets("BCP作成").Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets("BCP作成").Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets("BCP作成").Cells(DbServerRow, 2) End If If (Worksheets("BCP作成").Cells(6, 2) = "TI") Then Print #2, "isql -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -Q""truncate table " & bookName & """" End If Print #2, "bcp " & Worksheets("BCP作成").Cells(DbNameRow, 2) & ".." & bookName & " in " & SQLSheetName & " -U%UNAME% -P%PNAME% -S%SNAME% -c -b50000 >> " & LogPath Print #2, "" S = S + 1 SQLSheetName = Worksheets("BCP作成").Cells(SheetNameStartRow + S, 1) Wend Worksheets("BCP作成").Activate Print #2, "pause" Print #2, "" Close #2 AllSheetsMakeBCP_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub '実行！！ Sub AllSheetsMakeSP() createTable = False LogPath = Worksheets("バッチ作成").Cells(BatLogRow, 2) FilePath = Worksheets("バッチ作成").Cells(InPathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets("バッチ作成").Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If SQLSheetName = Worksheets("バッチ作成").Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, UCase(bookName), UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) - 1) 'CreateSP.bat作成 If (createTable = False) Then Filename = FilePath & "/" & CreateSPBat Open Filename For Output As #2 Print #2, "echo Function,SP追加 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets("バッチ作成").Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets("バッチ作成").Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets("バッチ作成").Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets("バッチ作成").Cells(DbServerRow, 2) Print #2, "" createTable = True End If Print #2, "echo " & sheetName & Worksheets("バッチ作成").Cells(SuffixRow, 2) & " >> " & LogPath Print #2, "isql -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -i" & SQLSheetName & ">> " & LogPath Print #2, "echo " & sheetName & Worksheets("バッチ作成").Cells(SuffixRow, 2) & " >> " & LogPath Print #2, "" S = S + 1 SQLSheetName = Worksheets("バッチ作成").Cells(SheetNameStartRow + S, 1) Wend Worksheets("バッチ作成").Activate Print #2, "pause" Print #2, "" Close #2 AllSheetsMakeSP_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub 'シート検索 Sub SheetNamesLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets(SheetNameIgnore).Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck(strDirName, strDirReturn) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck(strDirName, strDirReturn) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub '実行！！ Sub AllSheetsMakeCreateSQL() createTable = False createIndex = False Dim idxLogPath As String Dim findDotIndex As Integer Dim bookError As Integer Dim bookErrorCnt As Integer Dim bookErrorName As String On Error GoTo AllSheetsMakeCreateSQLError bookErrorName = "" bookError = 0 bookErrorCnt = 0 LogPath = Worksheets(SheetNameIgnore).Cells(BatLogRow, 2) If LogPath = "" Then If MsgBox("ログファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(BatLogRow, 2).Select Exit Sub End If End If idxLogPath = LogPath 'インデックスのログファイルパスとファイル名を設定。 findDotIndex = InStrRev(idxLogPath, ".") If findDotIndex > 0 Then '"."が見つかった場合 idxLogPath = (Left(idxLogPath, findDotIndex - 1) & "Index" & Right(idxLogPath, Len(idxLogPath) - findDotIndex + 1)) Else ' "."が見つからない場合 idxLogPath = idxLogPath & "Index" End If FilePath = Worksheets(SheetNameIgnore).Cells(FilePathRow, 2) IdxFilePath = Worksheets(SheetNameIgnore).Cells(IdxFilePathRow, 2) If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If If (Dir(IdxFilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + IdxFilePath End If If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" AllSheetsMakeCreateSQL_2: pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open SQLSheetName, , True bookError = 1 Workbooks(bookName).Worksheets(sheetName).Activate If bookError = 2 Then S = S + 1 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) GoTo AllSheetsMakeCreateSQL_2 End If bookError = 0 'SQL作成 rcd = MakeCreateSQL(FilePath, IdxFilePath, sheetName) If (rcd < 0) Then GoTo AllSheetsMakeCreateSQL_1 Workbooks(bookName).Close False S = S + 1 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) 'CreateTable.bat作成 If (createTable = False) Then Filename = FilePath & "/" & CreateTableBat Open Filename For Output As #2 Print #2, "echo テーブル作成 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets(SheetNameIgnore).Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets(SheetNameIgnore).Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets(SheetNameIgnore).Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets(SheetNameIgnore).Cells(DbServerRow, 2) Print #2, "" createTable = True End If Print #2, "echo " & sheetName & ".sql >> " & LogPath Print #2, "isql -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -i" & sheetName & ".sql >> " & LogPath Print #2, "echo " & sheetName & ".sql >> " & LogPath Print #2, "" 'CreateIndex.bat作成 If rcd = 1 Then If (createIndex = False) Then Filename = IdxFilePath & "/" & CreateIndexBat Open Filename For Output As #3 Print #3, "echo インデックス作成 > " & idxLogPath Print #3, "" Print #3, "cd /d " & IdxFilePath Print #3, "" Print #3, "set DBNAME=" & Worksheets(SheetNameIgnore).Cells(DbNameRow, 2) Print #3, "set UNAME=" & Worksheets(SheetNameIgnore).Cells(DbUserRow, 2) Print #3, "set PNAME=" & Worksheets(SheetNameIgnore).Cells(DbPswdRow, 2) Print #3, "set SNAME=" & Worksheets(SheetNameIgnore).Cells(DbServerRow, 2) Print #3, "" createIndex = True End If Print #3, "echo index_" & sheetName & ".sql >> " & idxLogPath Print #3, "isql -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -iindex_" & sheetName & ".sql >> " & idxLogPath Print #3, "echo index_" & sheetName & ".sql >> " & idxLogPath Print #3, "" End If Wend Worksheets(SheetNameIgnore).Activate Print #2, "pause" Print #2, "" Close #2 If (createIndex = True) Then Print #3, "pause" Print #3, "" End If Close #3 AllSheetsMakeCreateSQL_1: If (rcd >= 0) Then If (bookErrorCnt > 0) Then MsgBox bookErrorName + "だけ、作成に失敗しました。" Else MsgBox "ちゃんと出来ました。" End If Else MsgBox "ちゃんと出来ませんでした。" End If Exit Sub AllSheetsMakeCreateSQLError: If (Err = 9 And bookError = 1) Then Workbooks(bookName).Close bookError = 2 bookErrorCnt = bookErrorCnt + 1 If bookErrorName <> "" Then bookErrorName = bookErrorName + "," + bookName Else bookErrorName = bookName End If Resume Next Else MsgBox bookName + "作成中にエラー" + Error(Err) + Str(Err) End If End Sub 'SQLの作成 Function MakeCreateSQL(FilePath, IdxFilePath, SQLSheetName) As Integer Dim pry As Integer MakeCreateSQL = 0 ColID = "" ColAtt = "" ColLen = "" ColScaleLen = "" CreateCol = "" CreateCol2 = "" ColNotNull = "" ColDefault = "" ColPKey = "" ColIdentity = "" TableName = "" TableName_hist = "" CreateSQL = "" DropSQL = "" 'テーブル名 TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) 'ファイルグループ名 FileGroup = Worksheets(SQLSheetName).Cells(FileGroupRow, FileGroupCol) If InStr(1, FileGroup, "/") <> 0 Then FileGroupIdx = Mid(FileGroup, InStr(1, FileGroup, "/") + 1, Len(FileGroup)) FileGroup = Mid(FileGroup, 1, InStr(1, FileGroup, "/") - 1) Else FileGroupIdx = FileGroup End If 'ファイル名 Filename = FilePath & "/" & TableName & ".sql" Open Filename For Output As #1 '主キー ColPKey = ColPKey & FindCell(0, pry) CreateSQL = "" DolopSQL = "" For i = SQLCreateRow To 65535 '項目IDが設定されている場合 If Worksheets(SQLSheetName).Cells(i, ItemIDCol) <> "" Then If Len(Worksheets(SQLSheetName).Cells(i, ItemIDCol)) > 30 Then Worksheets(SQLSheetName).Cells(i, ItemIDCol).Select rcd = MsgBox("３０文字って決めたんだから守りましょう" + Chr(13) + Chr(13) + Worksheets(SQLSheetName).Cells(i, ItemNameCol) + Chr(13) + Worksheets(SQLSheetName).Cells(i, ItemIDCol) + Chr(13) + Chr(13) + "間違ってる所にカーソルがあるから、直しなさい", vbOKOnly) Close #1 MakeCreateSQL = -1 Exit Function End If '項目名 colName = Worksheets(SQLSheetName).Cells(i, ItemNameCol) '項目ID ColID = Worksheets(SQLSheetName).Cells(i, ItemIDCol) '属性 ColAtt = Worksheets(SQLSheetName).Cells(i, ItemAttributeCol) '有効桁数 ColLen = Worksheets(SQLSheetName).Cells(i, ItemLengthCol) '小数桁数 ColScaleLen = Worksheets(SQLSheetName).Cells(i, ItemScaleCol) 'Not Null ColNotNull = "" If Worksheets(SQLSheetName).Cells(i, ItemNotNullCol) = "○" Then ColNotNull = " NOT NULL" Else ColNotNull = " NULL" End If '初期値 ColIdentity = "" ColDefault = Worksheets(SQLSheetName).Cells(i, ItemDefaultCol) If ColDefault <> BLANK Or ColDefault = "0" Then If Left(ColDefault, 1) = """" And Right(ColDefault, 1) = """" Then Select Case VBA.UCase(ColAtt) Case "CHAR" ColDefault = "'" & String(ColLen, " ") & "'" Case "VARCHAR" ColDefault = "''" End Select Else If InStr(1, ColAtt, "CHAR") <> 0 Then If (UCase(ColDefault) <> "NULL") Then ColDefault = "'" & ColDefault & "'" End If End If End If If InStr(1, ColDefault, "IDENTITY") <> 0 Then ColIdentity = " " & ColDefault ColDefault = "" Else ColDefault = " DEFAULT " & ColDefault End If End If 'カラム作成情報の構築 CreateRow = "" CreateRow2 = "" Select Case VBA.UCase(ColAtt) Case "INT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "BIGINT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "SMALLINT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "TINYINT", "BIT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "DECIMAL" CreateRow = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColNotNull & ColDefault Case "MONEY" CreateRow = ColID & " " & ColAtt & ColNotNull & ColIdentity & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "DATETIME" CreateRow = ColID & " " & ColAtt & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "CHAR" CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault Case "VARCHAR", "NVARCHAR" CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault Case "TIMESTAMP" CreateRow = ColID & " " & ColAtt & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "IMAGE" CreateRow = ColID & " " & ColAtt & ColNotNull CreateRow2 = ColID & " " & ColAtt & ColNotNull End Select If Worksheets(SQLSheetName).Cells(i + 1, ItemIDCol) <> "" Then CreateRow = Mid(CreateRow & "," & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) & Chr(9) CreateRow2 = Mid(CreateRow2 & "," & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) & Chr(9) Else CreateRow = Mid(CreateRow & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) CreateRow2 = Mid(CreateRow2 & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) End If CreateCol = CreateCol & CreateRow CreateCol2 = CreateCol2 & CreateRow2 Else i = 9999999 'スペースカラムで終了とする End If Next i 'テーブル名 TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) Print #1, "/* " & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) & " */" Print #1, "/* $Header: $ */" 'Drop文作成 Print #1, "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[" & TableName & "]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" DropSQL = "DROP TABLE [dbo].[" & TableName & "]" Print #1, Chr(9) & DropSQL Print #1, "GO" Print #1, "" 'Create文最終構築 CreateSQL = "" Print #1, "CREATE TABLE dbo." & TableName & "(" '項目情報 & 主キー情報 If ColPKey <> "" Then CreateSQL = CreateCol & "PRIMARY KEY(" & ColPKey & ")" Else CreateSQL = CreateCol End If Print #1, Chr(9) & CreateSQL & ")" ' 主キー情報 If ColPKey <> "" Then Print #1, "ON [" & FileGroup & "]" End If Print #1, "GO" ' 変更履歴対象テーブル If Worksheets(SQLSheetName).Cells(7, 21) = "○" Then 'テーブル名 TableName_hist = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) + "_hist" 'Drop文作成 Print #1, "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[" & TableName_hist & "]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" DropSQL = "DROP TABLE [dbo].[" & TableName_hist & "]" Print #1, Chr(9) & DropSQL Print #1, "GO" Print #1, "" 'Create文最終構築 CreateSQL = "" Print #1, "CREATE TABLE dbo." & TableName_hist & "(" Print #1, Chr(9) + Mid("HistUnique TIMESTAMP NOT NULL," & Space(60), 1, 66) & "/* ユニークキー */" Print #1, Chr(9) + Mid("HistStatus CHAR(1) NOT NULL," & Space(60), 1, 66) & "/* 処理内容 */" CreateSQL = CreateCol2 & "PRIMARY KEY(HistUnique)" Print #1, Chr(9) & CreateSQL & ")" Print #1, "ON [" & FileGroup & "]" Print #1, "GO" End If 'ファイルを閉じる Close #1 'インデックファイル作成 For i = 1 To 30 colName = FindCell(i, pry) If colName = "" Then GoTo MakeCreateSQL_exit End If indexName = TableName & "_idx" & i If i = 1 Then Filename = IdxFilePath & "/" & "index_" & TableName & ".sql" Open Filename For Output As #1 Print #1, "--" & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) Print #1, "/* $Header: $ */" End If 'Drop文作成 Print #1, "IF EXISTS (SELECT name FROM sysindexes WHERE name = '" & indexName & "')" Print #1, Chr(9) & "DROP INDEX " & TableName & "." & indexName Print #1, "GO" Print #1, "" If (pry = 0) Then Print #1, "CREATE INDEX " & indexName Else Print #1, "CREATE UNIQUE NONCLUSTERED INDEX " & indexName End If Print #1, Chr(9) & "ON " & TableName & " (" & colName & ")" Print #1, Chr(9) & "ON [" & FileGroupIdx & "]" Print #1, "GO" Print #1, "" MakeCreateSQL = 1 Next i MakeCreateSQL_exit: If i <> 1 Then Close #1 End If End Function '実行！！ Sub AllSheetsMakeIF() FilePath = Worksheets(SheetNameHIF).Cells(FilePathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameHIF).Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If SQLSheetName = Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" '旧フォーマット If InStr(Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 2), "旧フォーマット") <> 0 Then MsgBox "旧フォーマットのレイアウトでは作れません" Exit Sub End If pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open SQLSheetName, , True Workbooks(bookName).Worksheets(sheetName).Activate 'SQL作成 rcd = MakeCreateIF(FilePath, sheetName) ' If Worksheets(SheetNameHIF).Cells(5, 2) = "DownBat" Then ' rcd = MakeCreateIF(FilePath, sheetName) ' Else ' rcd = MakeCreateIFPlus(FilePath, sheetName) ' End If If (rcd < 0) Then GoTo AllSheetsMakeCreateIF_1 Workbooks(bookName).Close False S = S + 1 SQLSheetName = Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 1) Wend AllSheetsMakeCreateIF_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub 'SQLの作成 Function MakeCreateIF(FilePath, SQLSheetName) As Integer Dim RowNum(1000) As Integer MakeCreateIF = -1 ColID = "" ColAtt = "" ColLen = "" ColScaleLen = "" CreateCol = "" CreateCol2 = "" ColNotNull = "" ColDefault = "" TableName = "" 'テーブル初期値 IFName = Worksheets(SQLSheetName).Cells(10, 19) AfterPGM = Worksheets(SQLSheetName).Cells(11, 19) BackupTBL = Worksheets(SQLSheetName).Cells(12, 19) CopyTBL = Worksheets(SQLSheetName).Cells(13, 19) DeleteTBL = Worksheets(SQLSheetName).Cells(14, 19) ModeUPD = Worksheets(SQLSheetName).Cells(15, 19) CommitCnt = Trim(Str(Worksheets(SQLSheetName).Cells(16, 19))) EOFSize = Trim(Str(Worksheets(SQLSheetName).Cells(17, 19))) TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) DeleteFlag = Worksheets(SQLSheetName).Cells(9, 19) 'ファイル名 BatFileName = FilePath & "/" & IFName & "bat.xml" DefFileName = FilePath & "/" & IFName & "def.xml" DatFileName = FilePath & "/" & IFName & ".dat" CsvFileName = FilePath & "/" & IFName & ".csv" 'batファイル作成 Open BatFileName For Output As #1 Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>" Print #1, "" Print #1, "<BATCHDEF>" Print #1, Chr(9) + "<ID>" + Worksheets(SQLSheetName).Cells(3, 5) + "</ID>" If BackupTBL = "○" Then Print #1, Chr(9) + "<BACKUPTABLE>" + TableName + "</BACKUPTABLE>" End If If CopyTBL = "○" Then Print #1, Chr(9) + "<COPYTABLE>" + TableName + "</COPYTABLE>" End If If DeleteTBL = "○" Then Print #1, Chr(9) + "<DELETETABLE>" + TableName + "</DELETETABLE>" End If Print #1, Chr(9) + "<IFS>" Print #1, Chr(9) + Chr(9) + "<IF>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_FILE>" + IFName + ".dat</IF_FILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_DEFFILE>" + IFName + "def.xml</IF_DEFFILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<EOFSIZE>" + EOFSize + "</EOFSIZE>" Print #1, Chr(9) + Chr(9) + "</IF>" Print #1, Chr(9) + Chr(9) + "<IF>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_FILE>" + IFName + ".csv</IF_FILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_DEFFILE>" + IFName + "def.xml</IF_DEFFILE>" Print #1, Chr(9) + Chr(9) + "</IF>" Print #1, Chr(9) + "</IFS>" If AfterPGM <> "" Then Print #1, Chr(9) + "<PROGRAM>" + AfterPGM + "</PROGRAM>" End If Print #1, "</BATCHDEF>" Close #1 'defファイル作成 Open DefFileName For Output As #1 Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>" Print #1, "" Print #1, "<IFDEF>" Print #1, Chr(9) + "<TABLE>" + TableName + "</TABLE>" Print #1, Chr(9) + "<COMMITSIZE>" + CommitCnt + "</COMMITSIZE>" Print #1, Chr(9) + "<MODE>" + ModeUPD + "</MODE>" Print #1, Chr(9) + "<COLUMNS>" If DeleteFlag = "○" Then Print #1, Chr(9) + Chr(9) + "<COLUMN>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<SIZE>1</SIZE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>DELETEFLAG</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<TYPE>C</TYPE>" Print #1, Chr(9) + Chr(9) + "</COLUMN>" End If RowCnt = 0 For i = 0 To 10000 '項目IDが設定されている場合 If Worksheets(SQLSheetName).Cells(i + SQLCreateRow, ItemIDCol) <> "" Then RowNum(i + 1) = Worksheets(SQLSheetName).Cells(i + SQLCreateRow, 41) RowCnt = RowCnt + 1 Else i = 9999999 'スペースカラムで終了とする End If Next i nowCnt = 0 endCnt = SQLCreateRow + RowCnt - 1 For i = SQLCreateRow To endCnt nowCnt = nowCnt + 1 nowPos = -1 For j = 1 To RowCnt If RowNum(j) = nowCnt Then nowPos = j + SQLCreateRow - 1 j = 9999999 'スペースカラムで終了とする End If Next j If nowPos < 0 Then Print #1, Chr(9) + Chr(9) + "<COLUMN>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>DUMMY</NAME>" Print #1, Chr(9) + Chr(9) + "</COLUMN>" Else '項目ID ColID = Worksheets(SQLSheetName).Cells(nowPos, ItemIDCol) '属性 ColAtt2 = Worksheets(SQLSheetName).Cells(nowPos, ItemAttributeCol) '有効桁数 ColLen = Trim(Str(Worksheets(SQLSheetName).Cells(nowPos, 29))) '小数桁数 ColScaleLen = Worksheets(SQLSheetName).Cells(nowPos, ItemScaleCol) '初期値 ColDefault = Worksheets(SQLSheetName).Cells(nowPos, 27) '関数名 ColFunction = Worksheets(SQLSheetName).Cells(nowPos, 31) 'セット項目 ColSet = Worksheets(SQLSheetName).Cells(nowPos, 33) 'MAX項目 ColMax = Worksheets(SQLSheetName).Cells(nowPos, 35) 'WHERE項目 ColWhere = Worksheets(SQLSheetName).Cells(nowPos, 37) 'GROUP項目 ColGroup = Worksheets(SQLSheetName).Cells(nowPos, 39) If ColFunction <> "" Then ColAtt = "F" Else ColAtt = "" End If Select Case VBA.UCase(ColAtt2) Case "INT" ColAtt = "N" + ColAtt Case "BIGINT" ColAtt = "N" + ColAtt Case "SMALLINT" ColAtt = "N" + ColAtt Case "TINYINT" ColAtt = "N" + ColAtt Case "DECIMAL" ColAtt = "N" + ColAtt Case "MONEY" ColAtt = "N" + ColAtt If ColScaleLen = "" Then ColScaleLen = "0" End If Case "DATETIME" ColAtt = "D" + ColAtt Case "CHAR" ColAtt = "C" + ColAtt Case "VARCHAR" ColAtt = "V" + ColAtt Case "TIMESTAMP" ColAtt = "C" + ColAtt Case "IMAGE" ColAtt = "C" + ColAtt End Select Print #1, Chr(9) + Chr(9) + "<COLUMN>" If (IsEmpty(ColDummy) Or Trim(ColDummy) = "") Then If Not (IsEmpty(ColDefault) Or Trim(ColDefault) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>" + ColID + "</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<VALUE>" + ColDefault + "</VALUE>" If Not (IsEmpty(ColSet) Or Trim(ColSet) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<SET>Y</SET>" End If Else Print #1, Chr(9) + Chr(9) + Chr(9) + "<SIZE>" + ColLen + "</SIZE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>" + ColID + "</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<TYPE>" + ColAtt + "</TYPE>" If Not (IsEmpty(ColScaleLen) Or Trim(ColScaleLen) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<DECIMALSIZE>" + Trim(Str(ColScaleLen)) + "</DECIMALSIZE>" End If If Not (IsEmpty(ColWhere) Or Trim(ColWhere) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<KEY>Y</KEY>" End If If Not (IsEmpty(ColFunction) Or Trim(ColFunction) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<FUNCTION>" + ColFunction + "</FUNCTION>" End If If Not (IsEmpty(ColMax) Or Trim(ColMax) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<MAX>Y</MAX>" End If If Not (IsEmpty(ColGroup) Or Trim(ColGroup) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<GROUP>Y</GROUP>" End If If Not (IsEmpty(ColSet) Or Trim(ColSet) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<SET>Y</SET>" End If End If End If Print #1, Chr(9) + Chr(9) + "</COLUMN>" End If Next i 'ファイルを閉じる Print #1, Chr(9) + "</COLUMNS>" Print #1, "</IFDEF>" Close #1 'If RecCnt <> nowCnt - 1 Then ' MsgBox "ちゃんと出来ませんでした、順位がおかしい、通番か確認しなさい。" 'Else MakeCreateIF = 0 'End If End Function 'SQLの作成 Function MakeCreateIFPlus(FilePath, SQLSheetName, DeleteFlag) As Integer MakeCreateIFPlus = -1 End Function Function FindCell(idx, pry As Integer) As String 'テーブル定義Sheetからキー定義部分を探す FindCell = "" pry = 0 Select Case idx Case Is < 10 s1 = Right(Str(idx), Len(Str(idx)) - 1) Case 10 s1 = "A" Case 11 s1 = "B" Case 12 s1 = "C" Case 13 s1 = "D" Case 14 s1 = "E" Case 15 s1 = "F" Case 16 s1 = "G" Case 17 s1 = "H" Case 18 s1 = "I" Case 19 s1 = "J" Case 20 s1 = "K" Case 21 s1 = "L" Case 22 s1 = "M" Case 23 s1 = "N" Case 24 s1 = "O" Case 25 s1 = "P" Case 26 s1 = "Q" Case 27 s1 = "R" Case 28 s1 = "S" Case 29 s1 = "T" Case 30 s1 = "U" End Select For i = 0 To 30 colName = Cells(SQLCreateRow, ItemIDCol) s2 = "[" + s1 s3 = "<" + s1 s4 = "{" + s1 j = 0 While colName <> "" vala = VBA.UCase(Cells(SQLCreateRow + j, ItemPKeyCol)) rcd2 = InStr(1, vala, s2) rcd3 = InStr(1, vala, s3) rcd4 = InStr(1, vala, s4) If Not (rcd2 = 0 And rcd3 = 0 And rcd4 = 0) Then If (rcd2 <> 0) Then rcd2 = rcd2 + 2 rcd = InStr(rcd2, vala, "]") rcd = Val(Mid(vala, rcd2, rcd - rcd2)) rcd1 = 1 End If If (rcd3 <> 0) Then rcd3 = rcd3 + 2 rcd = InStr(rcd3, vala, ">") rcd = Val(Mid(vala, rcd3, rcd - rcd3)) rcd1 = 2 End If If (rcd4 <> 0) Then rcd4 = rcd4 + 2 rcd = InStr(rcd4, vala, "}") rcd = Val(Mid(vala, rcd4, rcd - rcd4)) rcd1 = 3 End If If (rcd = i) Then If rcd1 = 2 Then colName = colName & " DESC" End If If rcd1 = 3 Then pry = 1 End If If FindCell = "" Then FindCell = colName Else FindCell = FindCell + ", " + colName End If GoTo FindCell_exit1 End If End If j = j + 1 colName = Cells(SQLCreateRow + j, ItemIDCol) Wend GoTo FindCell_exit2 FindCell_exit1: Next i FindCell_exit2: End Function 'バッチファイルを実行します Public Sub ExecCommand(sCommand As String) ' 変数宣言部 Dim oShell As Object, oExec As Object ' オブジェクト変数に参照をセットします。 Set oShell = CreateObject("WScript.Shell") oShell.Run sCommand, 0, True End Sub 'シート検索 Sub SheetNamesLineUpIF() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("ホストIF").Range("A" & SheetNameStartRow & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck3(strDirName, strDirReturn, SheetNameStartRow + i) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck3(strDirName, strDirReturn, SheetNameStartRow + i) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub

SQL2005

'CreateTable用　固定値 Const CreateTableBat = "CreateTable.bat" Const CreateIndexBat = "CreateIndex.bat" Const CreateSPBat = "CreateSP.bat" Const CreateBCPBat = "CreateBCP.bat" Const SheetNameIgnore = "設定・作成" Const SheetNameHIF = "ホストIF" Const SheetNameStartRow = 14 Const SheetNameStartCol = 1 Const DbTypeRow = 2 Const InPathRow = 3 Const FilePathRow = 4 Const SuffixRow = 4 Const IdxFilePathRow = 5 Const DbNameRow = 7 Const DbUserRow = 8 Const DbPswdRow = 9 Const DbServerRow = 10 Const BatLogRow = 11 '各テーブル定義書用　固定値 Const SQLCreateRow = 20 '項目開始行 Const ItemNameCol = 2 '項目名カラム Const ItemIDCol = 6 '項目IDカラム Const ItemAttributeCol = 10 '項目属性カラム Const ItemLengthCol = 12 '項目レングスカラム Const ItemScaleCol = 13 '項目小数点レングスカラム Const ItemPKeyCol = 15 '主キーカラム Const ItemNotNullCol = 16 'Not Null制約カラム Const ItemDefaultCol = 17 '初期値カラム Const TableNameRow = 4 Const TableNameCol = 5 Const FileGroupRow = 5 Const FileGroupCol = 14 'ブック名チェック Function BookCheck(pathName As String, bookName As String) As Integer On Error GoTo BookCheckError Dim sheetName As String BookCheck = 0 If bookName = "CreateSQL.xls" Then BookCheck = 1 Exit Function End If If InStr(1, bookName, ".xls") = 0 Then BookCheck = 1 Exit Function End If 'sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) 'Application.Workbooks.Open pathName + bookName, , True 'Workbooks(bookName).Worksheets(sheetName).Activate 'Workbooks(bookName).Close False Exit Function BookCheckError: If (Err = 9) Then BookCheck = 1 Workbooks(bookName).Close Exit Function End If End Function 'ブック名チェック Function BookCheck2(pathName As String, bookName As String, suffix As String) As Integer On Error GoTo BookCheck2Error Dim sheetName As String BookCheck2 = 0 If InStr(1, UCase(bookName), suffix) = 0 Then BookCheck2 = 1 Exit Function End If Exit Function BookCheck2Error: If (Err = 9) Then BookCheck2 = 1 Exit Function End If End Function 'ブック名チェック Function BookCheck3(pathName As String, bookName As String, pos As Integer) As Integer On Error GoTo BookCheck3Error Dim sheetName As String BookCheck3 = 0 If bookName = "CreateSQL.xls" Then BookCheck3 = 1 Exit Function End If If InStr(1, bookName, ".xls") = 0 Then BookCheck3 = 1 Exit Function End If sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open pathName + bookName, , True Workbooks(bookName).Worksheets(sheetName).Activate If (Worksheets(sheetName).Cells(18, 27) <> "ホストインターフェイス情報") Then BookCheck3 = 1 Else If (Worksheets(sheetName).Cells(8, 16) <> "ホストIF情報") Then Workbooks("CreateSQL.xls").Worksheets("ホストIF").Cells(pos, 2) = "旧フォーマットのレイアウトです、削除フラグは各テーブルレイアウトに定義してください" End If End If Workbooks(bookName).Close False Exit Function BookCheck3Error: If (Err = 9) Then BookCheck3 = 1 Workbooks(bookName).Close Exit Function End If End Function 'BCP検索 Sub BCPLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("BCP作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("BCP作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("BCP作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub 'SP検索 Sub SPLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("バッチ作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck2(strDirName, strDirReturn, UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub '実行！！ Sub AllSheetsMakeBCP() createTable = False LogPath = Worksheets("BCP作成").Cells(BatLogRow, 2) FilePath = Worksheets("BCP作成").Cells(InPathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets("BCP作成").Cells(FilePathRow, 2).Select Exit Sub End If End If If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If S = 0 SQLSheetName = Worksheets("BCP作成").Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" pos = InStrRev(SQLSheetName, "/") bookName = Mid(Mid(SQLSheetName, pos + 1), 1, Len(Mid(SQLSheetName, pos + 1)) - 4) If (S = 0) Then Filename = FilePath & "/" & CreateBCPBat Open Filename For Output As #2 Print #2, "echo BCP作成 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets("BCP作成").Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets("BCP作成").Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets("BCP作成").Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets("BCP作成").Cells(DbServerRow, 2) End If If (Worksheets("BCP作成").Cells(6, 2) = "TI") Then Print #2, "sqlcmd -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -Q""truncate table " & bookName & """" End If Print #2, "bcp " & Worksheets("BCP作成").Cells(DbNameRow, 2) & ".." & bookName & " in " & SQLSheetName & " -U%UNAME% -P%PNAME% -S%SNAME% -c -b50000 >> " & LogPath Print #2, "" S = S + 1 SQLSheetName = Worksheets("BCP作成").Cells(SheetNameStartRow + S, 1) Wend Worksheets("BCP作成").Activate Print #2, "pause" Print #2, "" Close #2 AllSheetsMakeBCP_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub '実行！！ Sub AllSheetsMakeSP() createTable = False LogPath = Worksheets("バッチ作成").Cells(BatLogRow, 2) FilePath = Worksheets("バッチ作成").Cells(InPathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets("バッチ作成").Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If SQLSheetName = Worksheets("バッチ作成").Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, UCase(bookName), UCase(Worksheets("バッチ作成").Cells(SuffixRow, 2))) - 1) 'CreateSP.bat作成 If (createTable = False) Then Filename = FilePath & "/" & CreateSPBat Open Filename For Output As #2 Print #2, "echo Function,SP追加 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets("バッチ作成").Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets("バッチ作成").Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets("バッチ作成").Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets("バッチ作成").Cells(DbServerRow, 2) Print #2, "" createTable = True End If Print #2, "echo " & sheetName & Worksheets("バッチ作成").Cells(SuffixRow, 2) & " >> " & LogPath Print #2, "sqlcmd -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -i" & SQLSheetName & ">> " & LogPath Print #2, "echo " & sheetName & Worksheets("バッチ作成").Cells(SuffixRow, 2) & " >> " & LogPath Print #2, "" S = S + 1 SQLSheetName = Worksheets("バッチ作成").Cells(SheetNameStartRow + S, 1) Wend Worksheets("バッチ作成").Activate Print #2, "pause" Print #2, "" Close #2 AllSheetsMakeSP_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub 'シート検索 Sub SheetNamesLineUp() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets(SheetNameIgnore).Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck(strDirName, strDirReturn) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck(strDirName, strDirReturn) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub '実行！！ Sub AllSheetsMakeCreateSQL() createTable = False createIndex = False Dim idxLogPath As String Dim findDotIndex As Integer Dim bookError As Integer Dim bookErrorCnt As Integer Dim bookErrorName As String On Error GoTo AllSheetsMakeCreateSQLError bookErrorName = "" bookError = 0 bookErrorCnt = 0 LogPath = Worksheets(SheetNameIgnore).Cells(BatLogRow, 2) If LogPath = "" Then If MsgBox("ログファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(BatLogRow, 2).Select Exit Sub End If End If idxLogPath = LogPath 'インデックスのログファイルパスとファイル名を設定。 findDotIndex = InStrRev(idxLogPath, ".") If findDotIndex > 0 Then '"."が見つかった場合 idxLogPath = (Left(idxLogPath, findDotIndex - 1) & "Index" & Right(idxLogPath, Len(idxLogPath) - findDotIndex + 1)) Else ' "."が見つからない場合 idxLogPath = idxLogPath & "Index" End If FilePath = Worksheets(SheetNameIgnore).Cells(FilePathRow, 2) IdxFilePath = Worksheets(SheetNameIgnore).Cells(IdxFilePathRow, 2) If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If If (Dir(IdxFilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + IdxFilePath End If If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" AllSheetsMakeCreateSQL_2: pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open SQLSheetName, , True bookError = 1 Workbooks(bookName).Worksheets(sheetName).Activate If bookError = 2 Then S = S + 1 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) GoTo AllSheetsMakeCreateSQL_2 End If bookError = 0 'SQL作成 rcd = MakeCreateSQL(FilePath, IdxFilePath, sheetName) If (rcd < 0) Then GoTo AllSheetsMakeCreateSQL_1 Workbooks(bookName).Close False S = S + 1 SQLSheetName = Worksheets(SheetNameIgnore).Cells(SheetNameStartRow + S, 1) 'CreateTable.bat作成 If (createTable = False) Then Filename = FilePath & "/" & CreateTableBat Open Filename For Output As #2 Print #2, "echo テーブル作成 > " & LogPath Print #2, "" Print #2, "cd /d " & FilePath Print #2, "" Print #2, "set DBNAME=" & Worksheets(SheetNameIgnore).Cells(DbNameRow, 2) Print #2, "set UNAME=" & Worksheets(SheetNameIgnore).Cells(DbUserRow, 2) Print #2, "set PNAME=" & Worksheets(SheetNameIgnore).Cells(DbPswdRow, 2) Print #2, "set SNAME=" & Worksheets(SheetNameIgnore).Cells(DbServerRow, 2) Print #2, "" createTable = True End If Print #2, "echo " & sheetName & ".sql >> " & LogPath Print #2, "sqlcmd -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -i" & sheetName & ".sql >> " & LogPath Print #2, "echo " & sheetName & ".sql >> " & LogPath Print #2, "" 'CreateIndex.bat作成 If rcd = 1 Then If (createIndex = False) Then Filename = IdxFilePath & "/" & CreateIndexBat Open Filename For Output As #3 Print #3, "echo インデックス作成 > " & idxLogPath Print #3, "" Print #3, "cd /d " & IdxFilePath Print #3, "" Print #3, "set DBNAME=" & Worksheets(SheetNameIgnore).Cells(DbNameRow, 2) Print #3, "set UNAME=" & Worksheets(SheetNameIgnore).Cells(DbUserRow, 2) Print #3, "set PNAME=" & Worksheets(SheetNameIgnore).Cells(DbPswdRow, 2) Print #3, "set SNAME=" & Worksheets(SheetNameIgnore).Cells(DbServerRow, 2) Print #3, "" createIndex = True End If Print #3, "echo index_" & sheetName & ".sql >> " & idxLogPath Print #3, "sqlcmd -U%UNAME% -P%PNAME% -S%SNAME% -d%DBNAME% -iindex_" & sheetName & ".sql >> " & idxLogPath Print #3, "echo index_" & sheetName & ".sql >> " & idxLogPath Print #3, "" End If Wend Worksheets(SheetNameIgnore).Activate Print #2, "pause" Print #2, "" Close #2 If (createIndex = True) Then Print #3, "pause" Print #3, "" End If Close #3 AllSheetsMakeCreateSQL_1: If (rcd >= 0) Then If (bookErrorCnt > 0) Then MsgBox bookErrorName + "だけ、作成に失敗しました。" Else MsgBox "ちゃんと出来ました。" End If Else MsgBox "ちゃんと出来ませんでした。" End If Exit Sub AllSheetsMakeCreateSQLError: If (Err = 9 And bookError = 1) Then Workbooks(bookName).Close bookError = 2 bookErrorCnt = bookErrorCnt + 1 If bookErrorName <> "" Then bookErrorName = bookErrorName + "," + bookName Else bookErrorName = bookName End If Resume Next Else MsgBox bookName + "作成中にエラー" + Error(Err) + Str(Err) End If End Sub 'SQLの作成 Function MakeCreateSQL(FilePath, IdxFilePath, SQLSheetName) As Integer Dim pry As Integer MakeCreateSQL = 0 ColID = "" ColAtt = "" ColLen = "" ColScaleLen = "" CreateCol = "" CreateCol2 = "" ColNotNull = "" ColDefault = "" ColPKey = "" ColIdentity = "" TableName = "" TableName_hist = "" CreateSQL = "" DropSQL = "" 'テーブル名 TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) 'ファイルグループ名 FileGroup = Worksheets(SQLSheetName).Cells(FileGroupRow, FileGroupCol) If InStr(1, FileGroup, "/") <> 0 Then FileGroupIdx = Mid(FileGroup, InStr(1, FileGroup, "/") + 1, Len(FileGroup)) FileGroup = Mid(FileGroup, 1, InStr(1, FileGroup, "/") - 1) Else FileGroupIdx = FileGroup End If 'ファイル名 Filename = FilePath & "/" & TableName & ".sql" Open Filename For Output As #1 '主キー ColPKey = ColPKey & FindCell(0, pry) CreateSQL = "" DolopSQL = "" For i = SQLCreateRow To 65535 '項目IDが設定されている場合 If Worksheets(SQLSheetName).Cells(i, ItemIDCol) <> "" Then If Len(Worksheets(SQLSheetName).Cells(i, ItemIDCol)) > 30 Then Worksheets(SQLSheetName).Cells(i, ItemIDCol).Select rcd = MsgBox("３０文字って決めたんだから守りましょう" + Chr(13) + Chr(13) + Worksheets(SQLSheetName).Cells(i, ItemNameCol) + Chr(13) + Worksheets(SQLSheetName).Cells(i, ItemIDCol) + Chr(13) + Chr(13) + "間違ってる所にカーソルがあるから、直しなさい", vbOKOnly) Close #1 MakeCreateSQL = -1 Exit Function End If '項目名 colName = Worksheets(SQLSheetName).Cells(i, ItemNameCol) '項目ID ColID = Worksheets(SQLSheetName).Cells(i, ItemIDCol) '属性 ColAtt = Worksheets(SQLSheetName).Cells(i, ItemAttributeCol) '有効桁数 ColLen = Worksheets(SQLSheetName).Cells(i, ItemLengthCol) '小数桁数 ColScaleLen = Worksheets(SQLSheetName).Cells(i, ItemScaleCol) 'Not Null ColNotNull = "" If Worksheets(SQLSheetName).Cells(i, ItemNotNullCol) = "○" Then ColNotNull = " NOT NULL" Else ColNotNull = " NULL" End If '初期値 ColIdentity = "" ColDefault = Worksheets(SQLSheetName).Cells(i, ItemDefaultCol) If ColDefault <> BLANK Or ColDefault = "0" Then If Left(ColDefault, 1) = """" And Right(ColDefault, 1) = """" Then Select Case VBA.UCase(ColAtt) Case "CHAR" ColDefault = "'" & String(ColLen, " ") & "'" Case "VARCHAR" ColDefault = "''" End Select Else If InStr(1, ColAtt, "CHAR") <> 0 Then If (UCase(ColDefault) <> "NULL") Then ColDefault = "'" & ColDefault & "'" End If End If End If If InStr(1, ColDefault, "IDENTITY") <> 0 Then ColIdentity = " " & ColDefault ColDefault = "" Else ColDefault = " DEFAULT " & ColDefault End If End If 'カラム作成情報の構築 CreateRow = "" CreateRow2 = "" Select Case VBA.UCase(ColAtt) Case "INT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "BIGINT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "SMALLINT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "TINYINT", "BIT" CreateRow = ColID & " " & ColAtt & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "DECIMAL" CreateRow = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColIdentity & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColNotNull & ColDefault Case "MONEY" CreateRow = ColID & " " & ColAtt & ColNotNull & ColIdentity & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "DATETIME" CreateRow = ColID & " " & ColAtt & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "CHAR" CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault Case "VARCHAR", "NVARCHAR" CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColNotNull & ColDefault Case "TIMESTAMP" CreateRow = ColID & " " & ColAtt & ColNotNull & ColDefault CreateRow2 = ColID & " " & ColAtt & ColNotNull & ColDefault Case "IMAGE" CreateRow = ColID & " " & ColAtt & ColNotNull CreateRow2 = ColID & " " & ColAtt & ColNotNull End Select If Worksheets(SQLSheetName).Cells(i + 1, ItemIDCol) <> "" Then CreateRow = Mid(CreateRow & "," & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) & Chr(9) CreateRow2 = Mid(CreateRow2 & "," & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) & Chr(9) Else CreateRow = Mid(CreateRow & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) CreateRow2 = Mid(CreateRow2 & Space(60), 1, 66) & "/* " & colName & " */" & VBA.Chr(13) End If CreateCol = CreateCol & CreateRow CreateCol2 = CreateCol2 & CreateRow2 Else i = 9999999 'スペースカラムで終了とする End If Next i 'テーブル名 TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) Print #1, "/* " & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) & " */" Print #1, "/* $Header: $ */" 'Drop文作成 Print #1, "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[" & TableName & "]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" DropSQL = "DROP TABLE [dbo].[" & TableName & "]" Print #1, Chr(9) & DropSQL Print #1, "GO" Print #1, "" 'SET句によるオプション設定（isqlと同じ設定にする） Print #1, "SET QUOTED_IDENTIFIER OFF" Print #1, "SET ANSI_PADDING OFF" Print #1, "SET ANSI_NULLS OFF" Print #1, "GO" Print #1, "" 'Create文最終構築 CreateSQL = "" Print #1, "CREATE TABLE dbo." & TableName & "(" '項目情報 & 主キー情報 If ColPKey <> "" Then CreateSQL = CreateCol & "PRIMARY KEY(" & ColPKey & ")" Else CreateSQL = CreateCol End If Print #1, Chr(9) & CreateSQL & ")" ' 主キー情報 If ColPKey <> "" Then Print #1, "ON [" & FileGroup & "]" End If Print #1, "GO" ' 変更履歴対象テーブル If Worksheets(SQLSheetName).Cells(7, 21) = "○" Then 'テーブル名 TableName_hist = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) + "_hist" 'Drop文作成 Print #1, "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[" & TableName_hist & "]') and OBJECTPROPERTY(id, N'IsUserTable') = 1)" DropSQL = "DROP TABLE [dbo].[" & TableName_hist & "]" Print #1, Chr(9) & DropSQL Print #1, "GO" Print #1, "" 'Create文最終構築 CreateSQL = "" Print #1, "CREATE TABLE dbo." & TableName_hist & "(" Print #1, Chr(9) + Mid("HistUnique TIMESTAMP NOT NULL," & Space(60), 1, 66) & "/* ユニークキー */" Print #1, Chr(9) + Mid("HistStatus CHAR(1) NOT NULL," & Space(60), 1, 66) & "/* 処理内容 */" CreateSQL = CreateCol2 & "PRIMARY KEY(HistUnique)" Print #1, Chr(9) & CreateSQL & ")" Print #1, "ON [" & FileGroup & "]" Print #1, "GO" End If 'ファイルを閉じる Close #1 'インデックファイル作成 For i = 1 To 30 colName = FindCell(i, pry) If colName = "" Then GoTo MakeCreateSQL_exit End If indexName = TableName & "_idx" & i If i = 1 Then Filename = IdxFilePath & "/" & "index_" & TableName & ".sql" Open Filename For Output As #1 Print #1, "--" & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) Print #1, "/* $Header: $ */" End If 'Drop文作成 Print #1, "IF EXISTS (SELECT name FROM sysindexes WHERE name = '" & indexName & "')" Print #1, Chr(9) & "DROP INDEX " & TableName & "." & indexName Print #1, "GO" Print #1, "" If (pry = 0) Then Print #1, "CREATE INDEX " & indexName Else Print #1, "CREATE UNIQUE NONCLUSTERED INDEX " & indexName End If Print #1, Chr(9) & "ON " & TableName & " (" & colName & ")" Print #1, Chr(9) & "ON [" & FileGroupIdx & "]" Print #1, "GO" Print #1, "" MakeCreateSQL = 1 Next i MakeCreateSQL_exit: If i <> 1 Then Close #1 End If End Function '実行！！ Sub AllSheetsMakeIF() FilePath = Worksheets(SheetNameHIF).Cells(FilePathRow, 2) If FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameHIF).Cells(FilePathRow, 2).Select Exit Sub End If End If S = 0 If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePath End If SQLSheetName = Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 1) While SQLSheetName <> "" '旧フォーマット If InStr(Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 2), "旧フォーマット") <> 0 Then MsgBox "旧フォーマットのレイアウトでは作れません" Exit Sub End If pos = InStrRev(SQLSheetName, "/") bookName = Mid(SQLSheetName, pos + 1) sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1) Application.Workbooks.Open SQLSheetName, , True Workbooks(bookName).Worksheets(sheetName).Activate 'SQL作成 rcd = MakeCreateIF(FilePath, sheetName) ' If Worksheets(SheetNameHIF).Cells(5, 2) = "DownBat" Then ' rcd = MakeCreateIF(FilePath, sheetName) ' Else ' rcd = MakeCreateIFPlus(FilePath, sheetName) ' End If If (rcd < 0) Then GoTo AllSheetsMakeCreateIF_1 Workbooks(bookName).Close False S = S + 1 SQLSheetName = Worksheets(SheetNameHIF).Cells(SheetNameStartRow + S, 1) Wend AllSheetsMakeCreateIF_1: If (rcd >= 0) Then MsgBox "ちゃんと出来ました。" End If End Sub 'SQLの作成 Function MakeCreateIF(FilePath, SQLSheetName) As Integer Dim RowNum(1000) As Integer MakeCreateIF = -1 ColID = "" ColAtt = "" ColLen = "" ColScaleLen = "" CreateCol = "" CreateCol2 = "" ColNotNull = "" ColDefault = "" TableName = "" 'テーブル初期値 IFName = Worksheets(SQLSheetName).Cells(10, 19) AfterPGM = Worksheets(SQLSheetName).Cells(11, 19) BackupTBL = Worksheets(SQLSheetName).Cells(12, 19) CopyTBL = Worksheets(SQLSheetName).Cells(13, 19) DeleteTBL = Worksheets(SQLSheetName).Cells(14, 19) ModeUPD = Worksheets(SQLSheetName).Cells(15, 19) CommitCnt = Trim(Str(Worksheets(SQLSheetName).Cells(16, 19))) EOFSize = Trim(Str(Worksheets(SQLSheetName).Cells(17, 19))) TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol) DeleteFlag = Worksheets(SQLSheetName).Cells(9, 19) 'ファイル名 BatFileName = FilePath & "/" & IFName & "bat.xml" DefFileName = FilePath & "/" & IFName & "def.xml" DatFileName = FilePath & "/" & IFName & ".dat" CsvFileName = FilePath & "/" & IFName & ".csv" 'batファイル作成 Open BatFileName For Output As #1 Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>" Print #1, "" Print #1, "<BATCHDEF>" Print #1, Chr(9) + "<ID>" + Worksheets(SQLSheetName).Cells(3, 5) + "</ID>" If BackupTBL = "○" Then Print #1, Chr(9) + "<BACKUPTABLE>" + TableName + "</BACKUPTABLE>" End If If CopyTBL = "○" Then Print #1, Chr(9) + "<COPYTABLE>" + TableName + "</COPYTABLE>" End If If DeleteTBL = "○" Then Print #1, Chr(9) + "<DELETETABLE>" + TableName + "</DELETETABLE>" End If Print #1, Chr(9) + "<IFS>" Print #1, Chr(9) + Chr(9) + "<IF>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_FILE>" + IFName + ".dat</IF_FILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_DEFFILE>" + IFName + "def.xml</IF_DEFFILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<EOFSIZE>" + EOFSize + "</EOFSIZE>" Print #1, Chr(9) + Chr(9) + "</IF>" Print #1, Chr(9) + Chr(9) + "<IF>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_FILE>" + IFName + ".csv</IF_FILE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<IF_DEFFILE>" + IFName + "def.xml</IF_DEFFILE>" Print #1, Chr(9) + Chr(9) + "</IF>" Print #1, Chr(9) + "</IFS>" If AfterPGM <> "" Then Print #1, Chr(9) + "<PROGRAM>" + AfterPGM + "</PROGRAM>" End If Print #1, "</BATCHDEF>" Close #1 'defファイル作成 Open DefFileName For Output As #1 Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>" Print #1, "" Print #1, "<IFDEF>" Print #1, Chr(9) + "<TABLE>" + TableName + "</TABLE>" Print #1, Chr(9) + "<COMMITSIZE>" + CommitCnt + "</COMMITSIZE>" Print #1, Chr(9) + "<MODE>" + ModeUPD + "</MODE>" Print #1, Chr(9) + "<COLUMNS>" If DeleteFlag = "○" Then Print #1, Chr(9) + Chr(9) + "<COLUMN>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<SIZE>1</SIZE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>DELETEFLAG</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<TYPE>C</TYPE>" Print #1, Chr(9) + Chr(9) + "</COLUMN>" End If RowCnt = 0 For i = 0 To 10000 '項目IDが設定されている場合 If Worksheets(SQLSheetName).Cells(i + SQLCreateRow, ItemIDCol) <> "" Then RowNum(i + 1) = Worksheets(SQLSheetName).Cells(i + SQLCreateRow, 41) RowCnt = RowCnt + 1 Else i = 9999999 'スペースカラムで終了とする End If Next i nowCnt = 0 endCnt = SQLCreateRow + RowCnt - 1 For i = SQLCreateRow To endCnt nowCnt = nowCnt + 1 nowPos = -1 For j = 1 To RowCnt If RowNum(j) = nowCnt Then nowPos = j + SQLCreateRow - 1 j = 9999999 'スペースカラムで終了とする End If Next j If nowPos < 0 Then Print #1, Chr(9) + Chr(9) + "<COLUMN>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>DUMMY</NAME>" Print #1, Chr(9) + Chr(9) + "</COLUMN>" Else '項目ID ColID = Worksheets(SQLSheetName).Cells(nowPos, ItemIDCol) '属性 ColAtt2 = Worksheets(SQLSheetName).Cells(nowPos, ItemAttributeCol) '有効桁数 ColLen = Trim(Str(Worksheets(SQLSheetName).Cells(nowPos, 29))) '小数桁数 ColScaleLen = Worksheets(SQLSheetName).Cells(nowPos, ItemScaleCol) '初期値 ColDefault = Worksheets(SQLSheetName).Cells(nowPos, 27) '関数名 ColFunction = Worksheets(SQLSheetName).Cells(nowPos, 31) 'セット項目 ColSet = Worksheets(SQLSheetName).Cells(nowPos, 33) 'MAX項目 ColMax = Worksheets(SQLSheetName).Cells(nowPos, 35) 'WHERE項目 ColWhere = Worksheets(SQLSheetName).Cells(nowPos, 37) 'GROUP項目 ColGroup = Worksheets(SQLSheetName).Cells(nowPos, 39) If ColFunction <> "" Then ColAtt = "F" Else ColAtt = "" End If Select Case VBA.UCase(ColAtt2) Case "INT" ColAtt = "N" + ColAtt Case "BIGINT" ColAtt = "N" + ColAtt Case "SMALLINT" ColAtt = "N" + ColAtt Case "TINYINT" ColAtt = "N" + ColAtt Case "DECIMAL" ColAtt = "N" + ColAtt Case "MONEY" ColAtt = "N" + ColAtt If ColScaleLen = "" Then ColScaleLen = "0" End If Case "DATETIME" ColAtt = "D" + ColAtt Case "CHAR" ColAtt = "C" + ColAtt Case "VARCHAR" ColAtt = "V" + ColAtt Case "TIMESTAMP" ColAtt = "C" + ColAtt Case "IMAGE" ColAtt = "C" + ColAtt End Select Print #1, Chr(9) + Chr(9) + "<COLUMN>" If (IsEmpty(ColDummy) Or Trim(ColDummy) = "") Then If Not (IsEmpty(ColDefault) Or Trim(ColDefault) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>" + ColID + "</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<VALUE>" + ColDefault + "</VALUE>" If Not (IsEmpty(ColSet) Or Trim(ColSet) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<SET>Y</SET>" End If Else Print #1, Chr(9) + Chr(9) + Chr(9) + "<SIZE>" + ColLen + "</SIZE>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<NAME>" + ColID + "</NAME>" Print #1, Chr(9) + Chr(9) + Chr(9) + "<TYPE>" + ColAtt + "</TYPE>" If Not (IsEmpty(ColScaleLen) Or Trim(ColScaleLen) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<DECIMALSIZE>" + Trim(Str(ColScaleLen)) + "</DECIMALSIZE>" End If If Not (IsEmpty(ColWhere) Or Trim(ColWhere) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<KEY>Y</KEY>" End If If Not (IsEmpty(ColFunction) Or Trim(ColFunction) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<FUNCTION>" + ColFunction + "</FUNCTION>" End If If Not (IsEmpty(ColMax) Or Trim(ColMax) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<MAX>Y</MAX>" End If If Not (IsEmpty(ColGroup) Or Trim(ColGroup) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<GROUP>Y</GROUP>" End If If Not (IsEmpty(ColSet) Or Trim(ColSet) = "") Then Print #1, Chr(9) + Chr(9) + Chr(9) + "<SET>Y</SET>" End If End If End If Print #1, Chr(9) + Chr(9) + "</COLUMN>" End If Next i 'ファイルを閉じる Print #1, Chr(9) + "</COLUMNS>" Print #1, "</IFDEF>" Close #1 'If RecCnt <> nowCnt - 1 Then ' MsgBox "ちゃんと出来ませんでした、順位がおかしい、通番か確認しなさい。" 'Else MakeCreateIF = 0 'End If End Function 'SQLの作成 Function MakeCreateIFPlus(FilePath, SQLSheetName, DeleteFlag) As Integer MakeCreateIFPlus = -1 End Function Function FindCell(idx, pry As Integer) As String 'テーブル定義Sheetからキー定義部分を探す FindCell = "" pry = 0 Select Case idx Case Is < 10 s1 = Right(Str(idx), Len(Str(idx)) - 1) Case 10 s1 = "A" Case 11 s1 = "B" Case 12 s1 = "C" Case 13 s1 = "D" Case 14 s1 = "E" Case 15 s1 = "F" Case 16 s1 = "G" Case 17 s1 = "H" Case 18 s1 = "I" Case 19 s1 = "J" Case 20 s1 = "K" Case 21 s1 = "L" Case 22 s1 = "M" Case 23 s1 = "N" Case 24 s1 = "O" Case 25 s1 = "P" Case 26 s1 = "Q" Case 27 s1 = "R" Case 28 s1 = "S" Case 29 s1 = "T" Case 30 s1 = "U" End Select For i = 0 To 30 colName = Cells(SQLCreateRow, ItemIDCol) s2 = "[" + s1 s3 = "<" + s1 s4 = "{" + s1 j = 0 While colName <> "" vala = VBA.UCase(Cells(SQLCreateRow + j, ItemPKeyCol)) rcd2 = InStr(1, vala, s2) rcd3 = InStr(1, vala, s3) rcd4 = InStr(1, vala, s4) If Not (rcd2 = 0 And rcd3 = 0 And rcd4 = 0) Then If (rcd2 <> 0) Then rcd2 = rcd2 + 2 rcd = InStr(rcd2, vala, "]") rcd = Val(Mid(vala, rcd2, rcd - rcd2)) rcd1 = 1 End If If (rcd3 <> 0) Then rcd3 = rcd3 + 2 rcd = InStr(rcd3, vala, ">") rcd = Val(Mid(vala, rcd3, rcd - rcd3)) rcd1 = 2 End If If (rcd4 <> 0) Then rcd4 = rcd4 + 2 rcd = InStr(rcd4, vala, "}") rcd = Val(Mid(vala, rcd4, rcd - rcd4)) rcd1 = 3 End If If (rcd = i) Then If rcd1 = 2 Then colName = colName & " DESC" End If If rcd1 = 3 Then pry = 1 End If If FindCell = "" Then FindCell = colName Else FindCell = FindCell + ", " + colName End If GoTo FindCell_exit1 End If End If j = j + 1 colName = Cells(SQLCreateRow + j, ItemIDCol) Wend GoTo FindCell_exit2 FindCell_exit1: Next i FindCell_exit2: End Function 'バッチファイルを実行します Public Sub ExecCommand(sCommand As String) ' 変数宣言部 Dim oShell As Object, oExec As Object ' オブジェクト変数に参照をセットします。 Set oShell = CreateObject("WScript.Shell") oShell.Run sCommand, 0, True End Sub 'シート検索 Sub SheetNamesLineUpIF() Dim mstrDirStack() As String Dim lngDirNum() As Long Dim lngDirPointer() As Long Dim strDirName As String Dim strDirReturn As String lngDirCnt1 = 0 lngDirCnt2 = 0 lngDirCnt3 = 0 blnDirExistFlag = False strFolderName = Cells(InPathRow, 2) Worksheets("ホストIF").Range("A" & SheetNameStartRow & ":A2000").Clear ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strFolderName lngDirCnt1 = lngDirCnt1 + 1 ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 i = 0 strDirName = strFolderName & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck3(strDirName, strDirReturn, SheetNameStartRow + i) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 Else Exit Sub End If Do blnDirExistFlag = False If lngDirCnt3 = 1 Then lngDirStart = 0 Else lngDirStart = lngDirPointer(lngDirCnt3 - 2) End If For lngFor_Cnt = lngDirStart To lngDirPointer(lngDirCnt3 - 1) - 1 strDirName = mstrDirStack(lngFor_Cnt) & "/" strDirReturn = Dir(strDirName, vbDirectory) Do While strDirReturn <> "" If strDirReturn <> "." And strDirReturn <> ".." Then If (GetAttr(strDirName & strDirReturn) And vbDirectory) = vbDirectory Then blnDirExistFlag = True ReDim Preserve mstrDirStack(lngDirCnt1) mstrDirStack(lngDirCnt1) = strDirName & strDirReturn lngDirCnt1 = lngDirCnt1 + 1 Else If (BookCheck3(strDirName, strDirReturn, SheetNameStartRow + i) = 0) Then Cells(SheetNameStartRow + i, SheetNameStartCol) = strDirName + strDirReturn i = i + 1 End If End If End If strDirReturn = Dir Loop If lngDirCnt1 <> 0 Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 End If Next lngFor_Cnt If blnDirExistFlag = True Then ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1 End If Loop While blnDirExistFlag = True End Sub

这篇关于Excel 应用07_自动生成Table和data作成_VBA的文章就介绍到这儿，希望我们推荐的文章对编程师们有所帮助！