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

SelectModule

 

Const SqlServerRow = 2Sub AllSheetsMakeCreateSQL() If ThisWorkbook.Worksheets("設定・作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeCreateSQL Else SQL2000.AllSheetsMakeCreateSQL End IfEnd SubSub AllSheetsMakeSP() If ThisWorkbook.Worksheets("バッチ作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeSP Else SQL2000.AllSheetsMakeSP End IfEnd SubSub AllSheetsMakeBCP() If ThisWorkbook.Worksheets("BCP作成").Cells(SqlServerRow, 2) = "SQLServer2005" Then SQL2005.AllSheetsMakeBCP Else SQL2000.AllSheetsMakeBCP End IfEnd 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 = 14Const SheetNameStartCol = 1Const DbTypeRow = 2Const InPathRow = 3Const FilePathRow = 4Const SuffixRow = 4Const IdxFilePathRow = 5Const DbNameRow = 7Const DbUserRow = 8Const DbPswdRow = 9Const DbServerRow = 10Const 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 = 4Const TableNameCol = 5Const FileGroupRow = 5Const FileGroupCol = 14'ブック名チェックFunction BookCheck(pathName As String, bookName As String) As IntegerOn Error GoTo BookCheckErrorDim sheetName As StringBookCheck = 0If bookName = "CreateSQL.xls" Then BookCheck = 1 Exit FunctionEnd IfIf InStr(1, bookName, ".xls") = 0 Then BookCheck = 1 Exit FunctionEnd If'sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1)'Application.Workbooks.Open pathName + bookName, , True'Workbooks(bookName).Worksheets(sheetName).Activate'Workbooks(bookName).Close FalseExit FunctionBookCheckError: If (Err = 9) Then BookCheck = 1 Workbooks(bookName).Close Exit Function End IfEnd Function'ブック名チェックFunction BookCheck2(pathName As String, bookName As String, suffix As String) As IntegerOn Error GoTo BookCheck2ErrorDim sheetName As StringBookCheck2 = 0If InStr(1, UCase(bookName), suffix) = 0 Then BookCheck2 = 1 Exit FunctionEnd IfExit FunctionBookCheck2Error: If (Err = 9) Then BookCheck2 = 1 Exit Function End IfEnd Function'ブック名チェックFunction BookCheck3(pathName As String, bookName As String, pos As Integer) As IntegerOn Error GoTo BookCheck3ErrorDim sheetName As StringBookCheck3 = 0If bookName = "CreateSQL.xls" Then BookCheck3 = 1 Exit FunctionEnd IfIf InStr(1, bookName, ".xls") = 0 Then BookCheck3 = 1 Exit FunctionEnd IfsheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1)Application.Workbooks.Open pathName + bookName, , TrueWorkbooks(bookName).Worksheets(sheetName).ActivateIf (Worksheets(sheetName).Cells(18, 27) <> "ホストインターフェイス情報") Then BookCheck3 = 1Else If (Worksheets(sheetName).Cells(8, 16) <> "ホストIF情報") Then Workbooks("CreateSQL.xls").Worksheets("ホストIF").Cells(pos, 2) = "旧フォーマットのレイアウトです、削除フラグは各テーブルレイアウトに定義してください" End IfEnd IfWorkbooks(bookName).Close FalseExit FunctionBookCheck3Error: If (Err = 9) Then BookCheck3 = 1 Workbooks(bookName).Close Exit Function End IfEnd Function'BCP検索Sub BCPLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("BCP作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'SP検索Sub SPLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("バッチ作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'実行！！Sub AllSheetsMakeBCP()createTable = FalseLogPath = 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 IfEnd IfIf (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfS = 0SQLSheetName = 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)WendWorksheets("BCP作成").ActivatePrint #2, "pause"Print #2, ""Close #2AllSheetsMakeBCP_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'実行！！Sub AllSheetsMakeSP()createTable = FalseLogPath = 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 IfEnd IfS = 0If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfSQLSheetName = 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)WendWorksheets("バッチ作成").ActivatePrint #2, "pause"Print #2, ""Close #2AllSheetsMakeSP_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'シート検索Sub SheetNamesLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets(SheetNameIgnore).Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'実行！！Sub AllSheetsMakeCreateSQL()createTable = FalsecreateIndex = FalseDim idxLogPath As StringDim findDotIndex As IntegerDim bookError As IntegerDim bookErrorCnt As IntegerDim bookErrorName As StringOn Error GoTo AllSheetsMakeCreateSQLErrorbookErrorName = ""bookError = 0bookErrorCnt = 0LogPath = 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 IfEnd IfidxLogPath = 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 IfFilePath = Worksheets(SheetNameIgnore).Cells(FilePathRow, 2)IdxFilePath = Worksheets(SheetNameIgnore).Cells(IdxFilePathRow, 2)If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfIf (Dir(IdxFilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + IdxFilePathEnd IfIf FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(FilePathRow, 2).Select Exit Sub End IfEnd IfS = 0SQLSheetName = 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 IfWendWorksheets(SheetNameIgnore).ActivatePrint #2, "pause"Print #2, ""Close #2If (createIndex = True) ThenPrint #3, "pause"Print #3, ""End IfClose #3AllSheetsMakeCreateSQL_1:If (rcd >= 0) Then If (bookErrorCnt > 0) Then MsgBox bookErrorName + "だけ、作成に失敗しました。" Else MsgBox "ちゃんと出来ました。" End IfElse MsgBox "ちゃんと出来ませんでした。"End IfExit SubAllSheetsMakeCreateSQLError: 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 IfEnd Sub'SQLの作成Function MakeCreateSQL(FilePath, IdxFilePath, SQLSheetName) As IntegerDim pry As IntegerMakeCreateSQL = 0ColID = ""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 = FileGroupEnd 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) & DropSQLPrint #1, "GO"Print #1, ""'Create文最終構築CreateSQL = ""Print #1, "CREATE TABLE dbo." & TableName & "("'項目情報 & 主キー情報If ColPKey <> "" Then CreateSQL = CreateCol & "PRIMARY KEY(" & ColPKey & ")"Else CreateSQL = CreateColEnd IfPrint #1, Chr(9) & CreateSQL & ")"' 主キー情報If ColPKey <> "" Then Print #1, "ON [" & FileGroup & "]"End IfPrint #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 = 1Next iMakeCreateSQL_exit:If i <> 1 Then Close #1End IfEnd 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 IfEnd IfS = 0If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfSQLSheetName = 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)WendAllSheetsMakeCreateIF_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'SQLの作成Function MakeCreateIF(FilePath, SQLSheetName) As IntegerDim RowNum(1000) As IntegerMakeCreateIF = -1ColID = ""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 #1Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>"Print #1, "<!-- $Header: $ -->"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 IfIf CopyTBL = "○" Then Print #1, Chr(9) + "<COPYTABLE>" + TableName + "</COPYTABLE>"End IfIf DeleteTBL = "○" Then Print #1, Chr(9) + "<DELETETABLE>" + TableName + "</DELETETABLE>"End IfPrint #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 IfPrint #1, "</BATCHDEF>"Close #1'defファイル作成Open DefFileName For Output As #1Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>"Print #1, "<!-- $Header: $ -->"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 = 0For 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 IfNext inowCnt = 0endCnt = SQLCreateRow + RowCnt - 1For 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 IfNext i 'ファイルを閉じるPrint #1, Chr(9) + "</COLUMNS>"Print #1, "</IFDEF>"Close #1'If RecCnt <> nowCnt - 1 Then' MsgBox "ちゃんと出来ませんでした、順位がおかしい、通番か確認しなさい。"'Else MakeCreateIF = 0'End IfEnd Function'SQLの作成Function MakeCreateIFPlus(FilePath, SQLSheetName, DeleteFlag) As IntegerMakeCreateIFPlus = -1End FunctionFunction 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_exit2FindCell_exit1: Next iFindCell_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, TrueEnd Sub'シート検索Sub SheetNamesLineUpIF()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("ホストIF").Range("A" & SheetNameStartRow & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd 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 = 14Const SheetNameStartCol = 1Const DbTypeRow = 2Const InPathRow = 3Const FilePathRow = 4Const SuffixRow = 4Const IdxFilePathRow = 5Const DbNameRow = 7Const DbUserRow = 8Const DbPswdRow = 9Const DbServerRow = 10Const 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 = 4Const TableNameCol = 5Const FileGroupRow = 5Const FileGroupCol = 14'ブック名チェックFunction BookCheck(pathName As String, bookName As String) As IntegerOn Error GoTo BookCheckErrorDim sheetName As StringBookCheck = 0If bookName = "CreateSQL.xls" Then BookCheck = 1 Exit FunctionEnd IfIf InStr(1, bookName, ".xls") = 0 Then BookCheck = 1 Exit FunctionEnd If'sheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1)'Application.Workbooks.Open pathName + bookName, , True'Workbooks(bookName).Worksheets(sheetName).Activate'Workbooks(bookName).Close FalseExit FunctionBookCheckError: If (Err = 9) Then BookCheck = 1 Workbooks(bookName).Close Exit Function End IfEnd Function'ブック名チェックFunction BookCheck2(pathName As String, bookName As String, suffix As String) As IntegerOn Error GoTo BookCheck2ErrorDim sheetName As StringBookCheck2 = 0If InStr(1, UCase(bookName), suffix) = 0 Then BookCheck2 = 1 Exit FunctionEnd IfExit FunctionBookCheck2Error: If (Err = 9) Then BookCheck2 = 1 Exit Function End IfEnd Function'ブック名チェックFunction BookCheck3(pathName As String, bookName As String, pos As Integer) As IntegerOn Error GoTo BookCheck3ErrorDim sheetName As StringBookCheck3 = 0If bookName = "CreateSQL.xls" Then BookCheck3 = 1 Exit FunctionEnd IfIf InStr(1, bookName, ".xls") = 0 Then BookCheck3 = 1 Exit FunctionEnd IfsheetName = Mid(bookName, 1, InStr(1, bookName, ".xls") - 1)Application.Workbooks.Open pathName + bookName, , TrueWorkbooks(bookName).Worksheets(sheetName).ActivateIf (Worksheets(sheetName).Cells(18, 27) <> "ホストインターフェイス情報") Then BookCheck3 = 1Else If (Worksheets(sheetName).Cells(8, 16) <> "ホストIF情報") Then Workbooks("CreateSQL.xls").Worksheets("ホストIF").Cells(pos, 2) = "旧フォーマットのレイアウトです、削除フラグは各テーブルレイアウトに定義してください" End IfEnd IfWorkbooks(bookName).Close FalseExit FunctionBookCheck3Error: If (Err = 9) Then BookCheck3 = 1 Workbooks(bookName).Close Exit Function End IfEnd Function'BCP検索Sub BCPLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("BCP作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'SP検索Sub SPLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("バッチ作成").Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'実行！！Sub AllSheetsMakeBCP()createTable = FalseLogPath = 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 IfEnd IfIf (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfS = 0SQLSheetName = 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)WendWorksheets("BCP作成").ActivatePrint #2, "pause"Print #2, ""Close #2AllSheetsMakeBCP_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'実行！！Sub AllSheetsMakeSP()createTable = FalseLogPath = 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 IfEnd IfS = 0If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfSQLSheetName = 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)WendWorksheets("バッチ作成").ActivatePrint #2, "pause"Print #2, ""Close #2AllSheetsMakeSP_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'シート検索Sub SheetNamesLineUp()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets(SheetNameIgnore).Range("A" & Mid(Str(SheetNameStartRow), 2) & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub'実行！！Sub AllSheetsMakeCreateSQL()createTable = FalsecreateIndex = FalseDim idxLogPath As StringDim findDotIndex As IntegerDim bookError As IntegerDim bookErrorCnt As IntegerDim bookErrorName As StringOn Error GoTo AllSheetsMakeCreateSQLErrorbookErrorName = ""bookError = 0bookErrorCnt = 0LogPath = 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 IfEnd IfidxLogPath = 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 IfFilePath = Worksheets(SheetNameIgnore).Cells(FilePathRow, 2)IdxFilePath = Worksheets(SheetNameIgnore).Cells(IdxFilePathRow, 2)If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfIf (Dir(IdxFilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + IdxFilePathEnd IfIf FilePath = "" Then If MsgBox("出力ファイルパスが書かれていません", vbOKOnly + vbCritical, "Create Insert SQL") = vbOK Then Worksheets(SheetNameIgnore).Cells(FilePathRow, 2).Select Exit Sub End IfEnd IfS = 0SQLSheetName = 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 IfWendWorksheets(SheetNameIgnore).ActivatePrint #2, "pause"Print #2, ""Close #2If (createIndex = True) ThenPrint #3, "pause"Print #3, ""End IfClose #3AllSheetsMakeCreateSQL_1:If (rcd >= 0) Then If (bookErrorCnt > 0) Then MsgBox bookErrorName + "だけ、作成に失敗しました。" Else MsgBox "ちゃんと出来ました。" End IfElse MsgBox "ちゃんと出来ませんでした。"End IfExit SubAllSheetsMakeCreateSQLError: 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 IfEnd Sub'SQLの作成Function MakeCreateSQL(FilePath, IdxFilePath, SQLSheetName) As IntegerDim pry As IntegerMakeCreateSQL = 0ColID = ""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 = FileGroupEnd 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) & DropSQLPrint #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 = CreateColEnd IfPrint #1, Chr(9) & CreateSQL & ")"' 主キー情報If ColPKey <> "" Then Print #1, "ON [" & FileGroup & "]"End IfPrint #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 = 1Next iMakeCreateSQL_exit:If i <> 1 Then Close #1End IfEnd 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 IfEnd IfS = 0If (Dir(FilePath, vbDirectory) = "") Then ExecCommand "cmd.exe /c mkdir " + FilePathEnd IfSQLSheetName = 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)WendAllSheetsMakeCreateIF_1:If (rcd >= 0) Then MsgBox "ちゃんと出来ました。"End IfEnd Sub'SQLの作成Function MakeCreateIF(FilePath, SQLSheetName) As IntegerDim RowNum(1000) As IntegerMakeCreateIF = -1ColID = ""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 #1Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>"Print #1, "<!-- $Header: $ -->"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 IfIf CopyTBL = "○" Then Print #1, Chr(9) + "<COPYTABLE>" + TableName + "</COPYTABLE>"End IfIf DeleteTBL = "○" Then Print #1, Chr(9) + "<DELETETABLE>" + TableName + "</DELETETABLE>"End IfPrint #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 IfPrint #1, "</BATCHDEF>"Close #1'defファイル作成Open DefFileName For Output As #1Print #1, "<?xml version=""1.0"" encoding=""Shift-JIS""?>"Print #1, "<!-- $Header: $ -->"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 = 0For 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 IfNext inowCnt = 0endCnt = SQLCreateRow + RowCnt - 1For 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 IfNext i 'ファイルを閉じるPrint #1, Chr(9) + "</COLUMNS>"Print #1, "</IFDEF>"Close #1'If RecCnt <> nowCnt - 1 Then' MsgBox "ちゃんと出来ませんでした、順位がおかしい、通番か確認しなさい。"'Else MakeCreateIF = 0'End IfEnd Function'SQLの作成Function MakeCreateIFPlus(FilePath, SQLSheetName, DeleteFlag) As IntegerMakeCreateIFPlus = -1End FunctionFunction 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_exit2FindCell_exit1: Next iFindCell_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, TrueEnd Sub'シート検索Sub SheetNamesLineUpIF()Dim mstrDirStack() As StringDim lngDirNum() As LongDim lngDirPointer() As LongDim strDirName As StringDim strDirReturn As StringlngDirCnt1 = 0lngDirCnt2 = 0lngDirCnt3 = 0blnDirExistFlag = FalsestrFolderName = Cells(InPathRow, 2)Worksheets("ホストIF").Range("A" & SheetNameStartRow & ":A2000").ClearReDim Preserve mstrDirStack(lngDirCnt1)mstrDirStack(lngDirCnt1) = strFolderNamelngDirCnt1 = lngDirCnt1 + 1ReDim Preserve lngDirNum(lngDirCnt2)lngDirNum(lngDirCnt2) = lngDirCnt1lngDirCnt2 = lngDirCnt2 + 1ReDim Preserve lngDirPointer(lngDirCnt3)lngDirPointer(lngDirCnt3) = lngDirCnt1lngDirCnt3 = lngDirCnt3 + 1i = 0strDirName = 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 = DirLoopIf blnDirExistFlag = True Then ReDim Preserve lngDirNum(lngDirCnt2) lngDirNum(lngDirCnt2) = lngDirCnt1 lngDirCnt2 = lngDirCnt2 + 1 ReDim Preserve lngDirPointer(lngDirCnt3) lngDirPointer(lngDirCnt3) = lngDirCnt1 lngDirCnt3 = lngDirCnt3 + 1Else Exit SubEnd IfDo 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 IfLoop While blnDirExistFlag = TrueEnd Sub