Function funct_CreateFLASH(CREATE_DATABASE_FULLNAME As String) As Variant
'分割用 確認完了
'汎用 NameListのエクスポートユニット
' テンポラリ・データベースを作る → クルーリストのデータをレコードセット → 読み込んだクルーリストの件数を返す
If Len(CREATE_DATABASE_FULLNAME) = 0 Then
funct_CreateFLASH = Array(-1, -1, -1)
Exit Function
End If
Dim myMDB_FullName As String
myMDB_FullName = CREATE_DATABASE_FULLNAME
Dim myDB As DAO.Database
Dim myRECORD As DAO.Recordset
Dim myTBL As DAO.TableDef
Dim myCrewRows(0 To 2) As Long
Dim myCrewRange As Range
Dim myTMP_ADDRESS(1 To 2) As String
Dim LoopEXPO As Long
Dim myRegularRange As Range
Dim mytraineeRange As Range
Dim myTmpCounter As Long
Dim myActivateCrews(1 To 2) As Long
Dim LoopTables As Integer
Dim LoopLAND As Integer
Dim LoopCapt As Integer
Dim strNOTES(0 To 1) As String
Dim boolFlag As Boolean
Dim varFlag As Variant
Dim lngDB_RES As Long
Dim strSQLCOMM As String
'レギュラーの範囲
Set myCrewRange = ActiveWorkbook.Sheets(NAME_LIST_SHEET).Range("レギュラー")
With myCrewRange
myCrewRows(1) = .Cells(.Rows.Count, 2).End(xlUp).Row
myCrewRows(1) = myCrewRows(1) - 1
myTMP_ADDRESS(1) = Range(.Cells(1, 1), .Cells(myCrewRows(1), .Columns.Count)).Address
End With
Set myCrewRange = Nothing
'新人の範囲
Set myCrewRange = ActiveWorkbook.Sheets(NAME_LIST_SHEET).Range("新人")
With myCrewRange
myCrewRows(2) = .Cells(.Rows.Count, 2).End(xlUp).Row
myCrewRows(2) = myCrewRows(2) - 1
myTMP_ADDRESS(2) = Range(.Cells(1, 1), .Cells(myCrewRows(2), .Columns.Count)).Address
End With
Set myCrewRange = Nothing
' _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
' _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'DBを削除する
Set objTarget = CreateObject("Scripting.FileSystemObject")
If objTarget.FileExists(myMDB_FullName) = True Then
Kill myMDB_FullName
End If
Set objTarget = Nothing
'---------------------------------------------------------------------------
'新規作成
Set myDB = CreateDatabase(myMDB_FullName, dbLangJapanese)
myDB.Close
Set myDB = Nothing
'---------------------------------------------------------------------------
'テーブル定義
Set myDB = OpenDatabase(myMDB_FullName)
Set myTBL = myDB.CreateTableDef(SCHE_DB)
With myTBL
.Fields.Append .CreateField("SortID", dbInteger)
.Fields.Append .CreateField("NickName", dbText, 255)
.Fields.Append .CreateField("InteriorRed", dbInteger)
.Fields.Append .CreateField("InteriorGreen", dbInteger)
.Fields.Append .CreateField("InteriorBlue", dbInteger)
.Fields.Append .CreateField("FontRed", dbInteger)
.Fields.Append .CreateField("FontGreen", dbInteger)
.Fields.Append .CreateField("FontBlue", dbInteger)
.Fields.Append .CreateField("Note_SCHE", dbText, 255)
.Fields.Append .CreateField("SH_Address", dbText, 255)
.Fields("NickName").AllowZeroLength = True
.Fields("Note_SCHE").AllowZeroLength = True
.Fields("SH_Address").AllowZeroLength = True
' 追加
.Fields.Append .CreateField("InvDate", dbDouble)
.Fields.Append .CreateField("Departure", dbDouble)
.Fields.Append .CreateField("InvStore", dbText, 255)
.Fields.Append .CreateField("SVName", dbText, 255)
.Fields("InvStore").AllowZeroLength = True
.Fields("SVName").AllowZeroLength = True
End With
myDB.TableDefs.Append myTBL
Set myTBL = Nothing
Set myTBL = myDB.CreateTableDef(CREW_DB)
With myTBL
.Fields.Append .CreateField("Syozoku", dbInteger)
.Fields.Append .CreateField("RowID", dbLong)
.Fields.Append .CreateField("IPL", dbLong)
.Fields.Append .CreateField("CrewName", dbText, 255)
.Fields.Append .CreateField("bNickName", dbText, 255)
.Fields.Append .CreateField("Unten", dbText, 255)
.Fields.Append .CreateField("Kobetsu", dbText, 255)
.Fields.Append .CreateField("ActiveAvail", dbText, 255)
.Fields.Append .CreateField("Note_CREW", dbText, 255)
.Fields.Append .CreateField("EMail", dbText, 255)
.Fields.Append .CreateField("Phonetic", dbText, 255)
.Fields("CrewName").AllowZeroLength = True
.Fields("bNickName").AllowZeroLength = True
.Fields("Unten").AllowZeroLength = True
.Fields("Kobetsu").AllowZeroLength = True
.Fields("ActiveAvail").AllowZeroLength = True
.Fields("Note_CREW").AllowZeroLength = True
.Fields("EMail").AllowZeroLength = True
.Fields("Phonetic").AllowZeroLength = True
End With
myDB.TableDefs.Append myTBL
Set myTBL = myDB.CreateTableDef(ACTB_DB)
With myTBL
.Fields.Append .CreateField("Act_WorkBook", dbText, 255)
.Fields("Act_WorkBook").AllowZeroLength = True
End With
myDB.TableDefs.Append myTBL
' _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
' _/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
' リストのインポート
Erase myActivateCrews
Set myRECORD = myDB.OpenRecordset(CREW_DB)
For LoopTables = 1 To 2
' 1回目 → レギュラー
' 2 → 新人
Set myCrewRange = ActiveWorkbook.Sheets(NAME_LIST_SHEET).Range(myTMP_ADDRESS(LoopTables))
With myCrewRange
For LoopEXPO = 1 To .Rows.Count
For LoopLAND = 1 To .Columns.Count
' ワークシート上にエラー値が存在する
If IsError(.Cells(LoopEXPO, LoopLAND).Value) = True Then
' エラーCallBackを返す
funct_CreateFLASH = Array(-3, -1, -1)
Set myCrewRange = Nothing
Set myRECORD = Nothing
Set myTBL = Nothing
myDB.Close
Set myDB = Nothing
Exit Function
End If
Next LoopLAND
Select Case True
Case (Val(.Cells(LoopEXPO, 1).Value) > 0) And (Len(.Cells(LoopEXPO, 2).Value) > 0) And (Len(.Cells(LoopEXPO, 3).Value) > 0)
myTmpCounter = myTmpCounter + 1
myRECORD.AddNew
myRECORD(0).Value = LoopTables
myRECORD(1).Value = .Cells(LoopEXPO, 1).Row
myRECORD(2).Value = Val(.Cells(LoopEXPO, 1).Value)
myRECORD(3).Value = CStr(.Cells(LoopEXPO, 2).Value)
myRECORD(4).Value = CStr(.Cells(LoopEXPO, 3).Value)
myRECORD(5).Value = CStr(.Cells(LoopEXPO, 4).Value)
myRECORD(6).Value = CStr(.Cells(LoopEXPO, 5).Value)
myRECORD(7).Value = CStr(.Cells(LoopEXPO, 6).Value)
If Len(myRECORD(7).Value) > 0 Then
myActivateCrews(LoopTables) = myActivateCrews(LoopTables) + 1
End If
' 全配列のコメントを取得する
Erase strNOTES
For LoopLAND = 1 To .Columns.Count
strNOTES(1) = CStr(.Cells(LoopEXPO, LoopLAND).NoteText)
If Len(strNOTES(0)) = 0 And Len(strNOTES(1)) > 0 Then
strNOTES(0) = strNOTES(1)
ElseIf Len(strNOTES(0)) > 0 And Len(strNOTES(1)) > 0 Then
strNOTES(0) = strNOTES(0) & CONV_CR_LETTER & strNOTES(1)
End If
Next LoopLAND
strNOTES(0) = funct_KAIGYOU_LETTER(strNOTES(0), True) '改行を $ に置き換える（データベースの障害防止）
myRECORD(8).Value = strNOTES(0)
' メアド
myRECORD(9).Value = CStr(.Cells(LoopEXPO, 7).Value)
myRECORD.Update
Erase strNOTES
End Select
Next
End With
Set myCrewRange = Nothing
Next LoopTables
Set myRECORD = Nothing
Set myTBL = Nothing
' ワークブック名
Set myRECORD = myDB.OpenRecordset(ACTB_DB)
With myRECORD
.AddNew
myRECORD(0).Value = ActiveWorkbook.Name
.Update
End With
Set myRECORD = Nothing
myDB.Close
Set myDB = Nothing
' _-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~_-~
' NameList 重複チェック
' 必須項目の重複を排除する
' ① IPL重複抽出クエリ
strSQLCOMM = "SELECT IPL" & Chr(10) & _
"FROM " & CREW_DB & Chr(10) & _
"GROUP BY IPL" & Chr(10) & _
"HAVING (((Count(Syozoku))>1));"
boolFlag = funct_mdbSQL_Create(myMDB_FullName, CREW_DB_CHK1, strSQLCOMM)
' ② 通称重複抽出クエリ
strSQLCOMM = "SELECT bNickName" & Chr(10) & _
"FROM " & CREW_DB & Chr(10) & _
"GROUP BY bNickName" & Chr(10) & _
"HAVING (((Count(Syozoku))>1));"
boolFlag = funct_mdbSQL_Create(myMDB_FullName, CREW_DB_CHK2, strSQLCOMM)
' ③ EMail重複抽出クエリ
strSQLCOMM = "SELECT EMail" & Chr(10) & _
"FROM " & CREW_DB & Chr(10) & _
"GROUP BY EMail" & Chr(10) & _
"HAVING (((Count(Syozoku))>1));"
boolFlag = funct_mdbSQL_Create(myMDB_FullName, CREW_DB_CHK3, strSQLCOMM)
' ④ 通称の文字列
strSQLCOMM = "SELECT bNickName" & Chr(10) & _
"FROM " & CREW_DB & Chr(10) & _
"GROUP BY bNickName" & Chr(10) & _
"HAVING (((Len(bNickName))>" & ALLOW_NICKNAME_LEN & "));"
boolFlag = funct_mdbSQL_Create(myMDB_FullName, CREW_DB_CHK4, strSQLCOMM)
' ⑤ 新規テーブルを作って、IPL重複レコードを追加する
strSQLCOMM = "SELECT " & CREW_DB & ".IPL, CrewName AS 氏名, bNickName AS 通称, EMail, " & _
"IIf([Syozoku] Is Null,'','') AS 通称_Len, " & _
"IIf([Syozoku] Is Null,'●','●') AS IPL_Dup, " & _
"IIf([Syozoku] Is Null,'','') AS 通称_Dup, " & _
"IIf([Syozoku] Is Null,'','') AS EMail_Dup" & _
" INTO " & CREW_ERR_DB & Chr(10) & _
"FROM " & CREW_DB & _
" LEFT JOIN " & CREW_DB_CHK1 & _
" ON " & CREW_DB & ".IPL = " & CREW_DB_CHK1 & ".IPL" & Chr(10) & _
"WHERE (((" & CREW_DB_CHK1 & ".IPL) Is Not Null));"
lngDB_RES = funct_mdbSQL_NEWTBL(myMDB_FullName, strSQLCOMM, CREW_ERR_DB)
' ⑥ 通称重複レコードを、⑤のテーブルに追加する
strSQLCOMM = "INSERT INTO " & CREW_ERR_DB & " ( IPL, 氏名, 通称, EMail, 通称_Len, IPL_Dup, 通称_Dup, EMail_Dup )" & Chr(10) & _
"SELECT IPL, CrewName AS 氏名, " & CREW_DB & ".bNickName AS 通称, EMail, " & _
"IIf([Syozoku] Is Null,'','') AS 通称の文字数, " & _
"IIf([Syozoku] Is Null,'','') AS IPL重複, " & _
"IIf([Syozoku] Is Null,'●','●') AS 通称重複, " & _
"IIf([Syozoku] Is Null,'','') AS EMail重複" & Chr(10) & _
"FROM " & CREW_DB & _
" LEFT JOIN " & CREW_DB_CHK2 & _
" ON " & CREW_DB & ".bNickName = " & CREW_DB_CHK2 & ".bNickName" & Chr(10) & _
"WHERE (((" & CREW_DB_CHK2 & ".bNickName) Is Not Null));"
lngDB_RES = lngDB_RES + funct_mdbSQL_ADDON(myMDB_FullName, strSQLCOMM, CREW_ERR_DB)
' ⑦ EMail重複レコードを、⑤のテーブルに追加する
strSQLCOMM = "INSERT INTO " & CREW_ERR_DB & " ( IPL, 氏名, 通称, EMail, 通称_Len, IPL_Dup, 通称_Dup, EMail_Dup )" & Chr(10) & _
"SELECT IPL, CrewName AS 氏名, bNickName AS 通称, " & CREW_DB & ".EMail, " & _
"IIf([Syozoku] Is Null,'','') AS 通称の文字数, " & _
"IIf([Syozoku] Is Null,'','') AS IPL重複, " & _
"IIf([Syozoku] Is Null,'','') AS 通称重複, " & _
"IIf([Syozoku] Is Null,'●','●') AS EMail重複" & Chr(10) & _
"FROM " & CREW_DB & _
" LEFT JOIN " & CREW_DB_CHK3 & _
" ON " & CREW_DB & ".EMail = " & CREW_DB_CHK3 & ".EMail" & Chr(10) & _
"WHERE (((IIf([" & CREW_DB & "].[EMail] Is Null Or Len([" & CREW_DB & "].[EMail])=0,0,1))=1)" & _
" AND ((" & CREW_DB_CHK3 & ".EMail) Is Not Null));"
lngDB_RES = lngDB_RES + funct_mdbSQL_ADDON(myMDB_FullName, strSQLCOMM, CREW_ERR_DB)
' ⑧ 通称の制限文字列オーバーを、⑤のテーブルに追加する
strSQLCOMM = "INSERT INTO " & CREW_ERR_DB & " ( IPL, 氏名, 通称, EMail, 通称_Len, IPL_Dup, 通称_Dup, EMail_Dup )" & Chr(10) & _
"SELECT IPL, CrewName AS 氏名, " & CREW_DB & ".bNickName AS 通称, " & CREW_DB & ".EMail, " & _
"IIf([Syozoku] Is Null,'" & ALLOW_NICKNAME_LEN & "文字以下に','" & ALLOW_NICKNAME_LEN & "文字以下に') AS 通称の文字数, " & _
"IIf([Syozoku] Is Null,'','') AS IPL重複, " & _
"IIf([Syozoku] Is Null,'','') AS 通称重複, " & _
"IIf([Syozoku] Is Null,'','') AS EMail重複" & Chr(10) & _
"FROM " & CREW_DB & _
" LEFT JOIN " & CREW_DB_CHK4 & _
" ON " & CREW_DB & ".bNickName = " & CREW_DB_CHK4 & ".bNickName" & Chr(10) & _
"WHERE (((" & CREW_DB_CHK4 & ".bNickName) Is Not Null));"
lngDB_RES = lngDB_RES + funct_mdbSQL_ADDON(myMDB_FullName, strSQLCOMM, CREW_ERR_DB)
' ⑨ 最終エラーリスト
strSQLCOMM = "SELECT IPL, 氏名, 通称, EMail, Max(通称_Len) AS 通称の文字数, Max(IPL_Dup) AS IPL重複, Max(通称_Dup) AS 通称重複, Max(EMail_Dup) AS EMail重複" & Chr(10) & _
"FROM " & CREW_ERR_DB & Chr(10) & _
"GROUP BY IPL, 氏名, 通称, EMail;"
boolFlag = funct_mdbSQL_Create(myMDB_FullName, CREW_ERR_XLS, strSQLCOMM)
If lngDB_RES > 0 Then
' 何かしらの重複レコードがある場合
' 新規ブックにエラーリストを作る
Workbooks.Add
Sheets(1).Select
strSQLCOMM = "SELECT *" & Chr(10) & "FROM " & CREW_ERR_XLS
varFlag = funct_SQL_ODBC(dirODBC(1) & ODBC_FLASH, "A1", strSQLCOMM, True, True)
' エラーCallBackを返す
funct_CreateFLASH = Array(-2, -1, -1)
Else
' 取得結果のCallBackを返す
' 戻り値
'総登録人数 レギュラー 新人
funct_CreateFLASH = Array(myTmpCounter, myActivateCrews(1), myActivateCrews(2))
End If
End Function