VBA SQL生成
'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 = 10 '項目開始行
Const ItemNameCol = 3 '項目名カラム
Const ItemIDCol = 10 '項目IDカラム
Const ItemAttributeCol = 18 '項目属性カラム
Const ItemLengthCol = 22 '項目レングスカラム
Const ItemScaleCol = 24 '項目小数点レングスカラム
Const ItemPKeyCol = 28 '主キーカラム
Const ItemNotNullCol = 26 'Not Null制約カラム
Const ItemDefaultCol = 30 '初期値カラム
Const SQLDefinedSheetName = "テーブル"
Const TableNameRow = 7
Const TableNameCol = 18
Const FileGroupRow = 7
Const FileGroupCol = 26
'ブック名チェック
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)
'CreateTable.bat作成
If (createTable = False) Then
Filename = FilePath & "\" & CreateSPBat
Open Filename For Output As #2
Print #2, "echo テーブル作成 > " & 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)
sheetName = SQLDefinedSheetName
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)
ColPKey = SetPrimaryKey()
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) = "Y" Then
ColNotNull = " NOT 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
If Left(ColDefault, 1) = "'" And Right(ColDefault, 1) = "'" Then
Select Case VBA.UCase(ColAtt)
Case "CHAR"
ColDefault = "'" & String(ColLen, " ") & "'"
'Case "VARCHAR"
Case Else
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 & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "BIGINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "SMALLINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "TINYINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DECIMAL"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColDefault & ColNotNull
Case "MONEY"
CreateRow = ColID & " " & ColAtt & ColNotNull & ColIdentity & ColDefault
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DATETIME"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DATE"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "CHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "VARCHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "VARCHAR2"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NVARCHAR2"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NVARCHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NUMBER"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "TIMESTAMP"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "IMAGE"
CreateRow = ColID & " " & ColAtt & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColNotNull
End Select
CreateRow = Chr(9) & CreateRow & "," & Chr(13) & Chr(10)
CreateRow2 = Chr(9) & CreateRow2 & "," & Chr(13) & Chr(10)
CreateCol = CreateCol & CreateRow
CreateCol2 = CreateCol2 & CreateRow2
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
'テーブル名
TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol)
Comment = "COMMENT ON TABLE KAMSSERVICE." & TableName & " IS '" & Worksheets(SQLSheetName).Cells(7, 1) & "'" & Chr(13) & Chr(10)
For i = SQLCreateRow To 65535
'項目名
colname = Worksheets(SQLSheetName).Cells(i, ItemNameCol)
'項目ID
ColID = Worksheets(SQLSheetName).Cells(i, ItemIDCol)
'項目IDが設定されている場合
If Worksheets(SQLSheetName).Cells(i, ItemIDCol) <> "" Then
Comment = Comment + "/" & Chr(13) & Chr(10) & "COMMENT ON COLUMN KAMSSERVICE." & TableName & "." & ColID & " IS '" & colname & "'" & Chr(13) & Chr(10)
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
'Print #1, "/* " & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) & " */"
'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 & "("
Print #1, "CREATE TABLE " & TableName & "("
'項目情報 & 主キー情報
If ColPKey <> "" Then
CreateSQL = CreateCol & "PRIMARY KEY(" & ColPKey & ")"
Else
CreateSQL = CreateCol
End If
Print #1, CreateSQL & ")" & Chr(13) & Chr(10) & "/" & Chr(13) & Chr(10) & Comment & "/"
' 主キー情報
'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, "<!-- $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 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, "<!-- $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 = 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 SetPrimaryKey() As String
'テーブル定義Sheetからキー定義部分を探す(仮)
For i = SQLCreateRow To 65535
If Cells(i, ItemIDCol) <> "" Then
vala = VBA.UCase(Cells(i, ItemPKeyCol))
If vala <> "" Then
SetPrimaryKey = SetPrimaryKey & Cells(i, ItemIDCol) & ","
End If
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
SetPrimaryKey = Left(SetPrimaryKey, Len(SetPrimaryKey) - 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("A14:B2000").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
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 = 10 '項目開始行
Const ItemNameCol = 3 '項目名カラム
Const ItemIDCol = 10 '項目IDカラム
Const ItemAttributeCol = 18 '項目属性カラム
Const ItemLengthCol = 22 '項目レングスカラム
Const ItemScaleCol = 24 '項目小数点レングスカラム
Const ItemPKeyCol = 28 '主キーカラム
Const ItemNotNullCol = 26 'Not Null制約カラム
Const ItemDefaultCol = 30 '初期値カラム
Const SQLDefinedSheetName = "テーブル"
Const TableNameRow = 7
Const TableNameCol = 18
Const FileGroupRow = 7
Const FileGroupCol = 26
'ブック名チェック
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)
'CreateTable.bat作成
If (createTable = False) Then
Filename = FilePath & "\" & CreateSPBat
Open Filename For Output As #2
Print #2, "echo テーブル作成 > " & 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)
sheetName = SQLDefinedSheetName
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)
ColPKey = SetPrimaryKey()
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) = "Y" Then
ColNotNull = " NOT 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
If Left(ColDefault, 1) = "'" And Right(ColDefault, 1) = "'" Then
Select Case VBA.UCase(ColAtt)
Case "CHAR"
ColDefault = "'" & String(ColLen, " ") & "'"
'Case "VARCHAR"
Case Else
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 & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "BIGINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "SMALLINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "TINYINT"
CreateRow = ColID & " " & ColAtt & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DECIMAL"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColIdentity & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & "," & ColScaleLen & ")" & ColDefault & ColNotNull
Case "MONEY"
CreateRow = ColID & " " & ColAtt & ColNotNull & ColIdentity & ColDefault
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DATETIME"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "DATE"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "CHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "VARCHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "VARCHAR2"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NVARCHAR2"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NVARCHAR"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "NUMBER"
CreateRow = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & "(" & ColLen & ")" & ColDefault & ColNotNull
Case "TIMESTAMP"
CreateRow = ColID & " " & ColAtt & ColDefault & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColDefault & ColNotNull
Case "IMAGE"
CreateRow = ColID & " " & ColAtt & ColNotNull
CreateRow2 = ColID & " " & ColAtt & ColNotNull
End Select
CreateRow = Chr(9) & CreateRow & "," & Chr(13) & Chr(10)
CreateRow2 = Chr(9) & CreateRow2 & "," & Chr(13) & Chr(10)
CreateCol = CreateCol & CreateRow
CreateCol2 = CreateCol2 & CreateRow2
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
'テーブル名
TableName = Worksheets(SQLSheetName).Cells(TableNameRow, TableNameCol)
Comment = "COMMENT ON TABLE KAMSSERVICE." & TableName & " IS '" & Worksheets(SQLSheetName).Cells(7, 1) & "'" & Chr(13) & Chr(10)
For i = SQLCreateRow To 65535
'項目名
colname = Worksheets(SQLSheetName).Cells(i, ItemNameCol)
'項目ID
ColID = Worksheets(SQLSheetName).Cells(i, ItemIDCol)
'項目IDが設定されている場合
If Worksheets(SQLSheetName).Cells(i, ItemIDCol) <> "" Then
Comment = Comment + "/" & Chr(13) & Chr(10) & "COMMENT ON COLUMN KAMSSERVICE." & TableName & "." & ColID & " IS '" & colname & "'" & Chr(13) & Chr(10)
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
'Print #1, "/* " & Worksheets(SQLSheetName).Cells(TableNameRow - 1, TableNameCol) & " */"
'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 & "("
Print #1, "CREATE TABLE " & TableName & "("
'項目情報 & 主キー情報
If ColPKey <> "" Then
CreateSQL = CreateCol & "PRIMARY KEY(" & ColPKey & ")"
Else
CreateSQL = CreateCol
End If
Print #1, CreateSQL & ")" & Chr(13) & Chr(10) & "/" & Chr(13) & Chr(10) & Comment & "/"
' 主キー情報
'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, "<!-- $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 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, "<!-- $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 = 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 SetPrimaryKey() As String
'テーブル定義Sheetからキー定義部分を探す(仮)
For i = SQLCreateRow To 65535
If Cells(i, ItemIDCol) <> "" Then
vala = VBA.UCase(Cells(i, ItemPKeyCol))
If vala <> "" Then
SetPrimaryKey = SetPrimaryKey & Cells(i, ItemIDCol) & ","
End If
Else
i = 9999999 'スペースカラムで終了とする
End If
Next i
SetPrimaryKey = Left(SetPrimaryKey, Len(SetPrimaryKey) - 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("A14:B2000").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