''''''''''''''''''''''''''''''''
Private Function Insert_New_Column_To_DataTable(ByVal DataTable_name As String, ByVal num As Long, _
ByVal col_type As Variant, ByVal col_name As Variant) As Object
'' データテーブルに列を追加
'' DataTable_name: DT名
'' numで指定した列番号のあとに新規列を追加
'' col_type: 追加する列のデータ型
'' col_name: 追加する列名
'' col_typeとcol_nameはデータ数が同じである必要があります。
''''''''''''''''''''''''''''''''
Dim pk As Long
Dim New_dt() As Variant
Dim ncol As Long
Dim new_dic As Object
Dim output As Object
Dim dic As Object
Dim n_check As Variant
Dim ch As Variant
Dim dt As Variant
Dim i, j As Long
If TypeName(col_type) = "String" And TypeName(col_name) = "String" Then
col_type = Array(col_type)
col_name = Array(col_name)
End If
If UBound(col_type) <> UBound(col_name) Then
MsgBox "col_nameとcol_typeのデータ数が違います。" & vbCrLf & _
"データ数を揃えてください。", vbInformation
Exit Function
End If
ncol = UBound(col_type) + 1
'' データを取得
Set dic = Read_DataTable(DataTable_name)
'' 列名の重複チェック
n_check = join(dic.item("name"), vbTab)
For Each ch In col_name
If InStr(n_check, ch) > 0 Then
Debug.Print "登録しようとしている列名に重複があります: " & ch
Exit Function
End If
Next
'' 配列化
dt = Dictionary_to_Array(dic)
'' プライマリーキー列
pk = dic.item("primary_key")(1)
If pk > num Then
dic.item("primary_key")(1) = pk + UBound(col_type) + 1
End If
'' 列を追加
ReDim New_dt(LBound(dt, 1) To UBound(dt, 1), LBound(dt, 2) To UBound(dt, 2) + UBound(col_type) + 1)
For j = LBound(dt, 2) To UBound(dt, 2)
'' 目的の列のあとに列を追加
If j <= num Then
For i = LBound(New_dt, 1) To UBound(New_dt, 1)
New_dt(i, j) = dt(i, j)
Next
Else
For i = LBound(New_dt, 1) To UBound(New_dt, 1)
New_dt(i, j + ncol) = dt(i, j)
Next
End If
Next
'' 追加列情報を登録
For j = LBound(col_type) To UBound(col_type)
New_dt(LBound(New_dt, 1), num + 1 + j) = col_type(j)
New_dt(LBound(New_dt, 1) + 1, num + 1 + j) = col_name(j)
Next
'' 配列からディクショナリーに変換
Set new_dic = Array_to_Dictionary(New_dt, pk)
'' データの上書き
Set output = OverWrite_DataTable(dic, new_dic)
Set Insert_New_Column_To_DataTable = output
'' データの保存
Call Write_DataTable(DataTable_name, output)
End Function
Private Function OverWrite_DataTable(ByVal dic As Object, ByVal new_dic As Object) As Object
Dim nkey As Variant
For Each nkey In new_dic
If dic.exists(nkey) Then
dic.item(nkey) = new_dic.item(nkey)
End If
Next
Set OverWrite_DataTable = dic
End Function
Private Function Array_to_Dictionary(ByVal dt As Variant, ByVal num As Long) As Object
'' num: プライマリーキー番号
'' dt: データテーブル
Dim dic As Object
Dim ar() As Variant
Dim i, j As Long
Set dic = Set_Dictionary
ReDim ar(LBound(dt, 2) To UBound(dt, 2))
For i = LBound(dt, 1) To UBound(dt, 1)
'' 登録データを1次元に変換
For j = LBound(dt, 2) To UBound(dt, 2)
ar(j) = dt(i, j)
Next
'' データを登録
Select Case ar(0)
Case "TYPE"
dic.Add "type", ar
Case "NAME"
dic.Add "name", ar
Case Else
dic.Add CStr(ar(num)), ar
End Select
'' 格納したデータを消去
For j = LBound(dt, 2) To UBound(dt, 2)
ar(j) = ""
Next
Next
Set Array_to_Dictionary = dic
End Function
'Private Function Update_DataTable(ByVal DataTable_name As String, _
' ByVal add_data As Variant) As Object
' '' 既存のデータテーブルに新たな行を追加
' '' add_data: Dictionary型を内包する配列型(array)
'
' Dim dic, New_dic As Object
' Dim cname As Variant
' Dim ncol As Long
' Dim pk As Long
' Dim ndim As Long
' Dim nrow As Long
' Dim dt, New_dt As Variant
' Dim ctype As Variant
' Dim dic_type As Object
' Dim set_date As String
' Dim i As Long
' Dim key_name As Variant
' Dim d As Variant
' Dim ikey As Variant
' Dim push As Variant
' Dim dkey As Variant
'
'
' '' 登録日作成
' set_date = Format(Now(), "yyyy-mm-dd hh:MM:ss")
' '' 一覧データ取得
' Set dic = Read_DataTable(DataTable_name)
' '' 列名取得
' cname = dic.item("name")
' '' データタイプ取得
' ctype = dic.item("type")
' Set dic_type = Set_Dictionary
' For i = LBound(cname) To UBound(cname)
' dic_type.Add cname(i), ctype(i)
' Next
'
' '' プライマリーキー列番号
' pk = dic.item("primary_key")(1)
'
' '' 列名をもとにDictionaryを作成
' Set New_dic = Set_Dictionary
' For Each key_name In cname
' New_dic.Add key_name, ""
' Next
'
' ''データ型を変換
' '' すでに変換されている場合は除外、2次元配列であれば変換
' If Search_Dimentions(add_data) = 2 Then
' add_data = Get_Table_To_Array(add_data)
' End If
'
' '' 新規データを登録
' For Each d In add_data
' ''データを修正
' For Each ikey In d
' If New_dic.exists(ikey) Then
' New_dic.item(ikey) = Input_Format(d.item(ikey), dic_type.item(ikey))
' End If
' Next
' New_dic.item("NAME") = set_date
' '' データ行を追加, 既存の場合は上書き
' push = New_dic.items
' If dic.exists(push(pk)) Then
' dic.item(push(pk)) = push
' Else
' dic.Add push(pk), push
' End If
'
' '' 既存のデータを一度消去
' For Each dkey In New_dic
' New_dic.item(dkey) = ""
' Next
' push = ""
' Next
'
' ''データを保存
' ''Call Write_DataTable(DataTable_name, New_dic)
' Set Update_DataTable = dic
'
'End Function
Private Function Update_DataTable(ByVal DataTable_name As String, _
ByVal add_data As Variant) As Object
'' 既存のデータテーブルに新たな行を追加
'' add_data: Dictionary型を内包する配列型(array)
Dim dic, new_dic As Object
Dim cName As Variant
Dim ncol As Long
Dim pk As Long
Dim ndim As Long
Dim nrow As Long
Dim dt, New_dt As Variant
Dim ctype As Variant
Dim dic_type As Object
Dim set_date As String
Dim i As Long
Dim key_name As Variant
Dim d As Variant
Dim ikey As Variant
Dim push As Variant
Dim dkey As Variant
Dim pkv As String
Dim set_values As Variant
'' 登録日作成
set_date = Format(Now(), "yyyy-mm-dd hh:MM:ss")
'' 一覧データ取得
Set dic = Read_DataTable(DataTable_name)
'' 列名取得
cName = dic.item("name")
'' データタイプ取得
ctype = dic.item("type")
Set dic_type = Set_Dictionary
For i = LBound(cName) To UBound(cName)
dic_type.Add cName(i), ctype(i)
Next
'' プライマリーキー列番号
pk = dic.item("primary_key")(1)
'' 列名をもとにDictionaryを作成
' Set new_dic = Set_Dictionary
' For Each key_name In cName
' new_dic.Add key_name, ""
' Next
''データ型を変換
'' すでに変換されている場合は除外、2次元配列であれば変換
If Search_Dimentions(add_data) = 2 Then
add_data = Get_Table_To_Array(add_data)
End If
'' 新規データを登録
For Each d In add_data
''キーを取得
pkv = d.item(cName(pk))
'' 既存のデータ検索
If dic.exists(pkv) Then
set_values = dic.item(pkv)
'' 初期値として既存のデータを指定
Set new_dic = Set_Dictionary
i = LBound(set_values)
For Each key_name In cName
new_dic.Add key_name, set_values(i)
i = i + 1
Next
Else
'' 初期値として既存のデータを指定
Set new_dic = Set_Dictionary
For Each key_name In cName
new_dic.Add key_name, ""
Next
End If
''データを修正
For Each ikey In d
If new_dic.exists(ikey) Then
new_dic.item(ikey) = Input_Format(d.item(ikey), dic_type.item(ikey))
End If
Next
new_dic.item("NAME") = set_date
'' データ行を追加, 既存の場合は上書き
push = new_dic.items
If dic.exists(pkv) Then
dic.item(pkv) = push
Else
dic.Add pkv, push
End If
'
' '' 既存のデータを一度消去
' For Each dkey In new_dic
' new_dic.item(dkey) = ""
' Next
push = ""
Next
''データを保存
''Call Write_DataTable(DataTable_name, New_dic)
Set Update_DataTable = dic
End Function
Private Function Dictionary_to_Array(ByVal dic As Object) As Variant
'' Dictionary → 二次元配列に変換
'' dicはDictionary型データを指定
Dim data() As Variant
Dim nrow, ncol As Long
Dim key_names As Variant
Dim i, j As Long
Dim ld As Variant
nrow = dic.Count - 1
' If nrow < 2 Then
' Debug.Print "データテーブルにデータが登録されていません。"
' Exit Function
' End If
key_names = dic.keys
ncol = UBound(dic.item(key_names(2)))
ReDim data(1 To nrow, ncol)
For i = 1 To nrow
ld = dic.item(key_names(i))
For j = 0 To ncol
data(i, j) = ld(j)
Next
ld = ""
Next
Dictionary_to_Array = data
End Function
Private Function Read_DataTable(ByVal DataTable_name As String) As Object
'' データテーブルを取り込み、Dictionary型で出力する関数
'' 区切り文字はタブ、改行文字はVbCr
Dim n As Integer
Dim i As LongPtr
Dim text As String
Dim dic As Object
Dim pk As Long
Dim data As Variant
Set dic = Set_Dictionary
n = FreeFile
Open DT_name(DataTable_name) For Input As #n
i = 1
Do While Not EOF(n)
Line Input #n, text
If text = "" Then GoTo Continue
Select Case i
Case 1
dic.Add "primary_key", Split(text, vbTab)
pk = CLng(dic.item("primary_key")(1))
Case 2
dic.Add "type", Split(text, vbTab)
Case 3
dic.Add "name", Split(text, vbTab)
Case Else
data = Split(text, vbTab)
dic.Add data(pk), data
End Select
Continue:
i = i + 1
Loop
Close #n
Set Read_DataTable = dic
End Function
Private Sub Add_Data_Table(ByVal name As String, ByVal KEY As LongPtr, _
ByVal col_type As Variant, ByVal col_name As Variant)
'' データテーブルを作成
'' name: DTの名称
'' KEY: Primary Keyの列番号 1～
'' col_type: 追加する列のデータ型
'' col_name: 追加する列名
'' col_typeとcol_nameはデータ数が同じである必要があります。
Dim n As Integer
Dim text As String
Dim filename As String
Dim msg As Variant
If TypeName(col_type) = "String" And TypeName(col_name) = "String" Then
col_type = Array(col_type)
col_name = Array(col_name)
End If
If UBound(col_type) <> UBound(col_name) Then
MsgBox "col_nameとcol_typeのデータ数が違います。" & vbCrLf & _
"データ数を揃えてください。", vbInformation
Exit Sub
End If
n = FreeFile
text = "PRIMARY KEY: " & vbTab & KEY & vbCr & _
"TYPE" & vbTab & join(col_type, vbTab) & vbCr & _
"NAME" & vbTab & join(col_name, vbTab) & vbCr
filename = DT_name(name)
If dir(filename, vbDirectory) <> "" Then
msg = MsgBox(name & ": このテーブルは既に作成されています。" & vbCrLf & _
"続行するとテーブルが削除されます。", vbYesNo)
If msg = 7 Then Exit Sub
End If
Open filename For Output As #n
Print #n, text
Close #n
Debug.Print "Create New Data Table: " & filename
End Sub
Public Sub WriteTableWithoutHeader(ByVal data_table_name As String, ByVal data_object As Variant)
Call Write_DataTable(data_table_name, data_object)
Call Make_Backup_File(data_table_name)
End Sub
Public Function ReadTableWithoutHeader(ByVal data_table_name As String, _
Optional read_type As readtype = readtype.RowHead, _
Optional separate_key As SepKey = SepKey.keyTab) As Object
'' データテーブルを取り込み、Dictionary型で出力する関数
'' 区切り文字はタブ、改行文字はVbCr
Dim n As Integer
Dim i As LongPtr
Dim text As String
Dim dic As Object
Dim pk As Long
Dim data As Variant
Set dic = Set_Dictionary
n = FreeFile
If InStr(data_table_name, "\") = 0 Then data_table_name = DT_name(data_table_name)
Open data_table_name For Input As #n
i = 1
Do While Not EOF(n)
Line Input #n, text
If text = "" Then GoTo Continue
If separate_key = keyTab Then
data = Split(text, vbTab)
ElseIf separate_key = keyComma Then
data = Split(text, ",")
End If
If read_type = readtype.RowHead Then
dic.Add CStr(data(0)), data
ElseIf read_type = readtype.Number Then
dic.Add CStr(i), data
End If
Continue:
i = i + 1
Loop
Close #n
Set ReadTableWithoutHeader = dic
End Function
Private Sub Write_DataTable(ByVal DataTable_name As String, ByVal Write_data As Variant)
'' データテーブルを上書き保存
'' DataTable_name: テーブル名
'' Write_data: 上書きするDictionary型データ
On Error GoTo Error
Dim n As Integer
Dim text As String
Dim filename As String
Dim dic As Object
Dim cnt As Long
Dim ikey As Variant
cnt = 1
Select Case VarType(Write_data)
Case 9 ''Object
Set dic = Set_Dictionary
For Each ikey In Write_data
dic.item(ikey) = join(Write_data.item(ikey), vbTab)
Next
text = join(dic.items, vbCr)
Case 8 '' String
text = Write_data
Case 8192 ''Array
End Select
filename = DT_name(DataTable_name)
Write_Run:
n = FreeFile
Open filename For Output Lock Write As #n
Print #n, text
Close #n
GoTo Continue
Error:
''openされていれば閉じる処理を追加
If Err.Number > 0 Then Close #n
If cnt > 5 Then
MsgBox "他のユーザーがファイルを開いています。少し待ってから再開してください。" & vbCrLf & _
"※ [OK]ボタンを押すと処理が再開します。", vbCritical
Else
Application.Wait Now() + TimeValue("00:00:01")
End If
cnt = cnt + 1
GoTo Write_Run
Continue:
Debug.Print "Save Data Table: " & filename
End Sub
Public Sub MakeDirectory(ByVal dir_name As String)
Call Create_New_Folder(dir_name)
End Sub
Private Sub Create_New_Folder(ByVal fold_name As String)
Dim fol_name As String
Dim check_dir As String
If fold_name = "" Then
fol_name = working_dir
Else
fol_name = Join_Path(working_dir, fold_name)
End If
check_dir = dir(fol_name, vbDirectory)
If check_dir = "" Then
mkdir fol_name
Debug.Print "Make directory: " & fol_name
End If
End Sub
Private Sub Set_New_Data_Base()
'' 新規でデータベースフォルダを作成
Dim dir_name As Variant
'' サブディレクトリの作成 ==============================
Call Create_New_Folder("")
' For Each dir_name In Array("Backups", "Report", "Picture")
' Call Create_New_Folder(dir_name)
' Next
Call Create_New_Folder("Backups")
End Sub
Private Function Search_Dimentions(ByVal dt As Variant) As Long
On Error GoTo Continue
Dim i As Integer
Dim nmax, nmin As Variant
Dim dims As String
i = 1
nmax = Empty
Do
nmax = UBound(dt, i)
If IsEmpty(nmax) Then GoTo Continue
i = i + 1
Loop
Continue:
Search_Dimentions = i - 1
End Function
Public Function Join_Path(ByVal path As String, ByVal name As String) As String
Join_Path = path & "\" & name
End Function
Private Function DT_name(ByVal name As String)
DT_name = Join_Path(working_dir, name & ".txt")
End Function
Public Function Set_Dictionary() As Object
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
Set Set_Dictionary = dic
End Function
Private Function QuickSort(ByVal data As Variant, ByVal L As Long, _
ByVal U As Long, ByVal order As Integer) As Variant
'' 逆順番に並び替え
'' data: 1次元配列
'' order: 0:昇順 1:降順
Dim i As Long
Dim j As Long
Dim S As Variant
Dim Tmp As Variant
Continue:
S = data(Int((L + U) / 2))
i = L
j = U
Do
If order = 0 Then
Do While data(i) < S
i = i + 1
Loop
Do While data(j) > S
j = j - 1
Loop
ElseIf order = 1 Then
Do While data(i) > S
i = i + 1
Loop
Do While data(j) < S
j = j - 1
Loop
End If
If i >= j Then Exit Do
Tmp = data(i)
data(i) = data(j)
data(j) = Tmp
i = i + 1
j = j - 1
Loop
If L < i - 1 Then
U = i - 1
L = L
GoTo Continue
End If
If U > j + 1 Then
L = j + 1
U = U
GoTo Continue
End If
QuickSort = data
End Function
Property Get WorkDir() As String
WorkDir = working_dir
End Property
Property Let WorkDir(ByVal working_directory As String)
working_dir = working_directory & "\data"
End Property
'Private Sub Class_Initialize()
' working_dir = "set-working-directory" & "\data"
'End Sub