●演習シート用
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge <= 100 Then
If Target.Count > 1 Then Exit Sub
Dim t_address
Dim t_value
t_address = Target.Address(False, False)
t_value = Target.Value
'Target.Addressを条件にテーブルからwordを取り出す
'wordとTarget.Valueを比較し、合っていたら文字の色を青にする、以外は赤にする
'xxと入れたら答えを記入
If t_value = "" Then Exit Sub
Dim dic_obj_select_info As Object
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
Dim select_dto As Object
dic_obj_select_info.Add GB_PLACE, t_address
Set select_dto = select_info(GB_T_FILL_WORD_TABLE, dic_obj_select_info, fill_word_table_map)
' Debug.Print "DB" & select_dto.Item(GB_WORD)
' Debug.Print "セル" & select_dto.Item(GB_WORD)
If select_dto.Count > 0 Then
If t_value = select_dto.Item(1).Item(GB_WORD) Then
Range(t_address).Font.ColorIndex = 5
Range(t_address).Font.Bold = True
'xxと入力された場合は答えを出す。
ElseIf t_value = "xx" Or t_value = "xx" Then
Range(t_address).Value = select_dto.Item(1).Item(GB_WORD)
Range(t_address).Font.ColorIndex = 1
Range(t_address).Font.Bold = True
Else
Range(t_address).Font.ColorIndex = 3
Range(t_address).Font.Bold = True
End If
End If
End If
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
End Sub
●edit_form用
Private Sub Label6_Click()
End Sub
Private Sub rate_ComboBox_Change()
End Sub
Private Sub regist_CommandButton_Click()
Call rgist_fill_question(2)
End Sub
Private Sub get_col_CommandButton_Click()
edit_Form.col_TextBox = ActiveCell.Column
End Sub
Private Sub get_row_CommandButton_Click()
edit_Form.row_TextBox.Value = ActiveCell.row
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub summary_TextBox_Change()
End Sub
Private Sub text_CommandButton_Click()
'---------------------temporary_tableからidを取得
Dim id As Long
Dim setter As Object
Dim getter As Object
Set setter = CreateObject("Scripting.Dictionary")
Set getter = CreateObject("Scripting.Dictionary")
setter.Add GB_T_ID, 1
Set getter = select_info(GB_T_TEMPORARY_TABLE, setter, temporary_table_map)
id = getter.Item(1).Item(GB_ID)
Set setter = Nothing
Set getter = Nothing
'---------------------law_info_tableのテキストページをフォームの値で更新する
Dim text_page As Long
Dim setter_target As Object
Dim setter_value As Object
Set setter_target = CreateObject("Scripting.Dictionary")
Set setter_value = CreateObject("Scripting.Dictionary")
text_page = Me.text_TextBox
setter_target.Add GB_ID, id
setter_value.Add GB_TEXT, text_page
Call update_info(GB_T_LAW_INFO_TABLE, setter_target, setter_value, law_info_table_map)
'---------------------temporary_tableのテキストページも更新
Set setter_target = Nothing
Set setter_target = CreateObject("Scripting.Dictionary")
setter_target.Add GB_T_ID, 1
Call update_info(GB_T_TEMPORARY_TABLE, setter_target, setter_value, temporary_table_map)
Set setter_target = Nothing
Set setter_value = Nothing
MsgBox "登録しました"
End Sub
Private Sub text_TextBox_Change()
End Sub
Private Sub UserForm_Initialize()
'
' 重要度の値をテンポラリーテーブルから取得
' Dim dic_obj_select_info As Object
' Dim select_dto As Object
' Dim t_rate As Object
'
' 検索条件の入れ物を用意
' Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'
' dic_obj_select_info.Add GB_ID, 1
'
' select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
'
' t_rate = select_dto.Item(1).Item(GB_RATE)
'
With rate_ComboBox
.AddItem 1
.AddItem 2
.AddItem 3
End With
' If t_rate <> "" Then
'
' rate_ComboBox.ListIndex = t_rate
'
' Else
'
' rate_ComboBox.ListIndex = -1
'
'
' End If
'
End Sub
★edit_form用各ボタン名
licence_TextBox
category_TextBox
no_TextBox
get_row_CommandButton
row_TextBox
get_col_CommandButton
col_TextBox
rate_ComboBox
text_TextBox
text_CommandButton
regist_CommandButton
●fill_chara_Form用
Private Sub CommandButton1_Click()
End Sub
Private Sub create_fill_chara_Click()
Call create_fill_in_the_blank_character
End Sub
Private Sub regist_fill_chara_Click()
Dim last_row As Long
Dim last_col As Long
last_row = fill_chara_Form.last_row_text
last_col = fill_chara_Form.last_col_text
Call register_fill_in_the_blank_character(last_row, last_col)
End Sub
Private Sub delete_line_Button_Click()
Call delete_line
End Sub
Private Sub drow_line_Button_Click()
Call drow_line
End Sub
Private Sub drow_line_Button2_Click()
Call drow_line2
End Sub
Private Sub row_delete_Click()
Call row_delete_1
End Sub
Private Sub row_insert_Click()
Call row_insert_1
End Sub
★fill_chara_Form用各ボタン
row_insert
row_delete
drow_line_Button
drow_line_Button2
delete_line_Button
●index_Form
Private Sub CommandButton1_Click()
regist_Form.Show vbModeless
End Sub
Private Sub open_law_Form_Click()
law_Form.Show vbModeless
End Sub
Private Sub opne_fill_chara_form_Click()
fill_chara_Form.Show vbModeless
End Sub
Private Sub UserForm_Click()
End Sub
★index_Form用各ボタン
open_law_Form
opne_fill_chara_form
CommandButton1
●law_Form
'Private Sub CommandButton1_Click()
'
'
' Dim str As String
'
' str = UserForm1.TextBox1.Value
'
' '改行コードを削除
'
' str = Replace(str, vbCrLf, "")
'' Debug.Print str
'
'
'' Call get_kanji(str)
' Call decompose_string(str)
'
'End Sub
Private Sub CommandButton2_Click()
Call create_fill_in_the_blank_character
End Sub
Private Sub CommandButton3_Click()
End Sub
Private Sub TextBox1_Change()
End Sub
Private Sub TextBox3_Change()
End Sub
Private Sub law_CommandButton_Click()
Dim str As String
str = law_Form.law_TextBox.Value
' '改行コードを削除
' str = Replace(str, vbCrLf, "")
'
' Call decompose_string(str)
'
str = Replace(str, vbCrLf, "/")
Call decompose_string_direct(str)
End Sub
Private Sub law_TextBox_Change()
End Sub
Private Sub reset_Button_Click()
Call reset_question
End Sub
★law_Form用ボタン
reset_Button
law_CommandButton
●regist_Form
Private Sub category_ComboBox_Change()
End Sub
Private Sub get_col_CommandButton_Click()
regist_Form.col_TextBox = ActiveCell.Column
End Sub
Private Sub get_row_CommandButton_Click()
regist_Form.row_TextBox.Value = ActiveCell.row
End Sub
Private Sub Label9_Click()
End Sub
Private Sub rate_ComboBox_Change()
End Sub
Private Sub summary_TextBox_Change()
End Sub
Private Sub UserForm_Initialize()
With licence_ComboBox
.AddItem "消防4類乙"
End With
licence_ComboBox.ListIndex = 0
With category_ComboBox
.AddItem "暗記"
End With
category_ComboBox.ListIndex = 0
With rate_ComboBox
.AddItem 1
.AddItem 2
.AddItem 3
End With
rate_ComboBox.ListIndex = 0
End Sub
Private Sub CommandButton1_Click()
End Sub
Private Sub regist_CommandButton_Click()
If regist_Form.no_TextBox = "" Then
MsgBox "NOが指定されていません"
End
End If
Call rgist_fill_question(1)
End Sub
Private Sub UserForm_Click()
End Sub
★regist_Form用ボタン
licence_ComboBox
category_ComboBox
no_TextBox
get_row_CommandButton
row_TextBox
get_col_CommandButton
col_TextBox
rate_ComboBox
regist_CommandButton
●DB用
Option Explicit
Enum law_info_table
id = 1
licence
category
num
row
col
t_rate
t_summary
del_flg
t_text
t_text_name
times
sub_category
End Enum
Enum fill_word_table
id = 1
place
word
End Enum
Enum temporary_table
t_id = 1
id
licence
category
num
row
col
t_rate
t_summary
t_text
End Enum
Enum number_table
t_id = 1
number1
number2
number3
End Enum
Enum question_cycle_table
t_id = 1
license
sub_category
times
End Enum
Function select_info(table_name As String, ByVal select_dto As Object, table_map As Object) As Object
'情報の曖昧検索をする関数
'引数1:検索するテーブル名
'引数2:検索条件
'引数3:検索対象テーブルのマッピング情報
Dim tbList As ListObject
Dim record_count As Long
Dim i As Long
Dim j As Long
Dim dicKey_select As Variant
Dim serch_count As Long
Dim record As String
Dim search_Word As String
serch_count = 0
' Dim dicItem_select As Variant
Dim dicKey_table As Variant
dicKey_select = select_dto.keys
' dicItem_select = select_dto.items
dicKey_table = table_map.keys
'検索結果返却用
Dim dic_obj_result As Object
Set dic_obj_result = CreateDictionary
' Worksheets(table_name).Activate
Set tbList = CreateTableList(table_name)
'Set tbList = Worksheets(table_name).ListObjects(table_name)
record_count = tbList.ListRows.Count
With ThisWorkbook.Worksheets(table_name)
For i = 2 To record_count + 1
For j = 0 To UBound(dicKey_select)
'テーブルの検索対象情報
'todo 検索語に関しては前段階で小文字に変換できないか考える
'dictoinaryのキーの配列はすでに持ってるのだから、開けて変換して戻すくらいはできるはず
search_Word = ""
record = ""
search_Word = select_dto.Item(dicKey_select(j))
search_Word = StrConv(LCase(search_Word), vbNarrow)
'search_Word = Replace(search_Word, " ", "*")
record = .Cells(i, table_map.Item(dicKey_select(j))).Value
record = StrConv(LCase(record), vbNarrow)
' If Not record Like "*" & search_Word & "*" Then
'
' GoTo Skip
'
' End If
If Not record Like search_Word Then
GoTo Skip
End If
' If .Cells(i, table_map.Item(dicKey_select(j))).Value <> select_dto.Item(dicKey_select(j)) Then
'
' GoTo Skip
'
' End If
Next j
'子ディクショナリ
Dim c_dic_obj_result As Object
Set c_dic_obj_result = CreateDictionary
serch_count = serch_count + 1
'ここに来れたなら、条件がすべて一致しているはず。
For j = 0 To UBound(dicKey_table)
'テーブルの目的の行を追加する
c_dic_obj_result.Add dicKey_table(j), .Cells(i, table_map.Item(dicKey_table(j))).Value
Next j
'親ディクショナリに子ディクショナリを追加
dic_obj_result.Add serch_count, c_dic_obj_result
'for文を抜ける
' Exit For
Skip:
Next i
End With
Set select_info = dic_obj_result
End Function
Function insert_info(table_name As String, ByVal insert_dto As Object, table_map As Object)
'情報の登録を行う関数
'引数1:登録を行テーブル名
'引数2:登録内容
'引数3:登録テーブルのマッピング情報
Dim dicKey_table As Variant
Dim dicKey_insert As Variant
Dim i As Long
Dim tbList As ListObject
Set tbList = Worksheets(table_name).ListObjects(table_name)
dicKey_insert = insert_dto.keys
dicKey_table = table_map.keys
With tbList.ListRows.Add
For i = 0 To UBound(dicKey_insert)
.Range(table_map.Item(dicKey_insert(i))).Value = insert_dto(dicKey_insert(i))
Next i
End With
End Function
Function update_info(table_name As String, ByVal search_dto, ByVal update_dto As Object, table_map As Object)
'情報を更新する関数 検索条件は複数可能
'引数1:更新を行テーブル名
'引数2:更新を行うレコードの条件(ID=1)とか
'引数2:更新内容
'引数3:更新テーブルのマップ
Dim record_count As Long
Dim dicKey_serch As Variant
Dim dicKey_update As Variant
Dim dicKey_table As Variant
Dim tbList As ListObject
Set tbList = Worksheets(table_name).ListObjects(table_name)
Dim i As Long
Dim j As Long
record_count = tbList.ListRows.Count
dicKey_serch = search_dto.keys
dicKey_update = update_dto.keys
dicKey_table = table_map.keys
With Worksheets(table_name)
For i = 2 To record_count + 1
For j = 0 To UBound(dicKey_serch)
If .Cells(i, table_map.Item(dicKey_serch(j))).Value <> search_dto.Item(dicKey_serch(j)) Then
GoTo Skip
End If
Next j
'ここに来れたなら、条件がすべて一致しているはず。
For j = 0 To UBound(dicKey_update)
.Cells(i, table_map.Item(dicKey_update(j))).Value = update_dto.Item(dicKey_update(j))
Next j
Skip:
Next i
End With
End Function
Function law_info_table_map() As Object
'テーブル内でのカラムの位置をマッピングするやーつ
'このカラム名称だと1列目とか~
Dim dic_obj_law_info_table As Object
Set dic_obj_law_info_table = CreateObject("Scripting.Dictionary")
dic_obj_law_info_table.Add GB_ID, law_info_table.id
dic_obj_law_info_table.Add GB_LICENCE, law_info_table.licence
dic_obj_law_info_table.Add GB_CATEGORY, law_info_table.category
dic_obj_law_info_table.Add GB_NUM, law_info_table.num
dic_obj_law_info_table.Add GB_ROW, law_info_table.row
dic_obj_law_info_table.Add GB_COL, law_info_table.col
dic_obj_law_info_table.Add GB_RATE, law_info_table.t_rate
dic_obj_law_info_table.Add GB_SUMMARY, law_info_table.t_summary
dic_obj_law_info_table.Add GB_DEL_FLG, law_info_table.del_flg
dic_obj_law_info_table.Add GB_TEXT, law_info_table.t_text
dic_obj_law_info_table.Add GB_C_TEXT_NAME, law_info_table.t_text_name
dic_obj_law_info_table.Add GB_C_TIMES, law_info_table.times
dic_obj_law_info_table.Add GB_C_SUB_CATEGORY, law_info_table.sub_category
Set law_info_table_map = dic_obj_law_info_table
End Function
Function fill_word_table_map() As Object
Dim dic_obj_fill_word_table As Object
Set dic_obj_fill_word_table = CreateObject("Scripting.Dictionary")
dic_obj_fill_word_table.Add GB_ID, fill_word_table.id
dic_obj_fill_word_table.Add GB_PLACE, fill_word_table.place
dic_obj_fill_word_table.Add GB_WORD, fill_word_table.word
Set fill_word_table_map = dic_obj_fill_word_table
End Function
Function temporary_table_map() As Object
Dim dic_obj_temporary_table As Object
Set dic_obj_temporary_table = CreateObject("Scripting.Dictionary")
dic_obj_temporary_table.Add GB_T_ID, temporary_table.t_id
dic_obj_temporary_table.Add GB_ID, temporary_table.id
dic_obj_temporary_table.Add GB_LICENCE, temporary_table.licence
dic_obj_temporary_table.Add GB_CATEGORY, temporary_table.category
dic_obj_temporary_table.Add GB_NUM, temporary_table.num
dic_obj_temporary_table.Add GB_ROW, temporary_table.row
dic_obj_temporary_table.Add GB_COL, temporary_table.col
dic_obj_temporary_table.Add GB_RATE, temporary_table.t_rate
dic_obj_temporary_table.Add GB_SUMMARY, temporary_table.t_summary
dic_obj_temporary_table.Add GB_TEXT, temporary_table.t_text
Set temporary_table_map = dic_obj_temporary_table
End Function
Function number_table_map() As Object
Dim dic_obj_temporary_table As Object
Set dic_obj_temporary_table = CreateObject("Scripting.Dictionary")
dic_obj_temporary_table.Add GB_T_ID, number_table.t_id
dic_obj_temporary_table.Add GB_NUMBER1, number_table.number1
dic_obj_temporary_table.Add GB_NUMBER2, number_table.number2
dic_obj_temporary_table.Add GB_NUMBER3, number_table.number3
Set number_table_map = dic_obj_temporary_table
End Function
Function question_cycle_table_map() As Object
Dim dic_obj As Object
Set dic_obj = CreateDictionary
dic_obj.Add GB_ID, question_cycle_table.t_id
dic_obj.Add GB_LICENCE, question_cycle_table.license
dic_obj.Add GB_C_SUB_CATEGORY, question_cycle_table.sub_category
dic_obj.Add GB_C_TIMES, question_cycle_table.times
Set question_cycle_table_map = dic_obj
End Function
●common_function
Option Explicit
Function CreateDictionary() As Object
'ディクショナリーオブジェクトを作成して返却する関数
Dim dicObj As Object
Set dicObj = CreateObject("Scripting.Dictionary")
Set CreateDictionary = dicObj
End Function
Function CreateTableList(tableName As String) As Object
Dim tableList As ListObject
Set tableList = ThisWorkbook.Worksheets(tableName).ListObjects(tableName)
Set CreateTableList = tableList
End Function
●module1
Option Explicit
'law_info_table
Public Const GB_ID = "ID"
Public Const GB_LICENCE = "licence"
Public Const GB_CATEGORY = "category"
Public Const GB_NUM = "num"
Public Const GB_ROW = "row"
Public Const GB_COL = "col"
Public Const GB_RATE = "rate"
Public Const GB_SUMMARY = "summary"
Public Const GB_DEL_FLG = "del_flg"
Public Const GB_TEXT = "text"
Public Const GB_C_TEXT_NAME = "text_name"
Public Const GB_C_TIMES = "times"
Public Const GB_C_SUB_CATEGORY = "sub_category"
Public Const GB_PLACE = "place"
Public Const GB_WORD = "word"
Public Const GB_T_ID = "t_ID"
Public Const GB_TABLE = "table"
Public Const GB_NUMBER1 = "number1"
Public Const GB_NUMBER2 = "number2"
Public Const GB_NUMBER3 = "number3"
'question_cycle_table
Public Const GB_C_ID = "ID"
Public Const GB_C_SUBJECTS = "subjects"
'Public Const GB_C_CATEGORY = "category"
'Public Const GB_C_TIMES = "times"
Public Const GB_T_LAW_INFO_TABLE = "law_info_table"
Public Const GB_T_FILL_WORD_TABLE = "fill_word_table"
Public Const GB_T_TEMPORARY_TABLE = "temporary_table"
Public Const GB_T_NUMBER_TABLE = "number_table"
Public Const GB_T_QUESTION_CYCLE_TABLE = "question_cycle_table"
Sub create_fill_in_the_blank_character()
'選択した文字列を穴埋め形式にする(文字列を[]で囲む)
'[]で囲まれた文字が穴埋め文字列となり、呼び出されたときに解釈される
Dim rng As Range
Set rng = Selection
' Debug.Print (c.Value)
Dim i As Long
Dim str As Variant
Application.DisplayAlerts = False
For i = 1 To rng.Count
str = str & rng.Item(i)
Next i
'①一列挿入
Range(rng.Item(1).Address(False, False)).Insert shift:=xlShiftToRight
'Debug.Print rng.Item(1).Address(False, False)
'②①で挿入した列に識別文字を挿入
Range(Range(rng.Item(1).Address(False, False)).Offset(0, -1).Address(False, False)).Value = "["
Range(Range(rng.Item(rng.Count).Address(False, False)).Offset(0, 1).Address(False, False)).Insert shift:=xlShiftToRight
Range(Range(rng.Item(rng.Count).Address(False, False)).Offset(0, 1).Address(False, False)).Value = "]"
'Debug.Print rng.Item(rng.Count).Address(False, False)
'以下マージを行う
' Range(rng.Item(1).Address(False, False) & ":" & rng.Item(rng.Count).Address(False, False)).Merge
'
' Range(rng.Item(1).Address(False, False)).Value = str
Application.DisplayAlerts = True
End Sub
Sub row_insert_1()
'選択したセルに一列追加
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Selection
Dim i As Long
For i = 1 To rng.Count
' Debug.Print i & ":" & rng.Item(i).Address(False, False)
Range(rng.Item(i).Address(False, False)).Insert shift:=xlShiftToRight
Next i
Application.ScreenUpdating = True
End Sub
Sub row_delete_1()
'選択したセルを1列削除
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Selection
Dim i As Long
' For i = 1 To rng.Count
'
' Debug.Print i & ":" & rng.Item(i).Address(False, False)
'
' Range(rng.Item(i).Address(False, False)).Delete (xlShiftToLeft)
'
' Next i
'減少カウンタを使う理由
'https://teratail.com/questions/75463
For i = rng.Count To 1 Step -1
Range(rng.Item(i).Address(False, False)).Delete (xlShiftToLeft)
Next i
Application.ScreenUpdating = True
End Sub
Sub drow_line()
'選択したセルの外側に罫線を引く
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Selection
Dim bs As Border
Set bs = rng.Borders(xlEdgeTop)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeBottom)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeLeft)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeRight)
bs.LineStyle = xlContinuous
End Sub
Sub drow_line2()
'選択したセルの外側に罫線を引く
'水平線も引く
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Selection
Dim bs As Border
Set bs = rng.Borders(xlEdgeTop)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeBottom)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeLeft)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlEdgeRight)
bs.LineStyle = xlContinuous
Set bs = rng.Borders(xlInsideHorizontal)
bs.LineStyle = xlContinuous
End Sub
Sub delete_line()
'選択したセルの罫線を削除する
Application.ScreenUpdating = False
Dim rng As Range
Set rng = Selection
rng.Borders.LineStyle = xlLineStyleNone
End Sub
Function rgist_fill_question(mode As Long)
'mode1:通常登録
'mode2:編集登録存在チェックを行わない
Dim newBookName As String
Dim savepath As String
Dim newBook As Workbook
Dim sheetname As String
Dim id As Long
Dim licence_chara As String
Dim category_chara As String
Dim no_chara As String
Dim row As Long
Dim col As Long
Dim t_rate As Long
Dim summary As String
Dim dic_obj_select_info As Object
Dim select_dto As Object
Dim tbList As ListObject
If mode = 1 Then
licence_chara = regist_Form.licence_ComboBox.Value
category_chara = regist_Form.category_ComboBox.Value
no_chara = regist_Form.no_TextBox
row = regist_Form.row_TextBox
col = regist_Form.col_TextBox
sheetname = licence_chara & "_" & category_chara & "_" & no_chara
t_rate = regist_Form.rate_ComboBox.ListIndex
summary = regist_Form.summary_TextBox
'-------------情報登録-------------
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'存在チェックを行う
dic_obj_select_info.Add GB_LICENCE, licence_chara
dic_obj_select_info.Add GB_CATEGORY, category_chara
dic_obj_select_info.Add GB_NUM, no_chara
' dic_obj_select_info.Add GB_RATE, t_rate
' dic_obj_search_info.Add GB_SUMMARY, summary
Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
If select_dto.Count > 0 Then
MsgBox "登録済みの問題です。"
End
End If
'情報登録を行う
Dim dic_obj_insert_info As Object
Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1
dic_obj_insert_info.Add GB_LICENCE, licence_chara
dic_obj_insert_info.Add GB_CATEGORY, category_chara
dic_obj_insert_info.Add GB_NUM, no_chara
dic_obj_insert_info.Add GB_ROW, row
dic_obj_insert_info.Add GB_COL, col
dic_obj_insert_info.Add GB_RATE, t_rate
dic_obj_insert_info.Add GB_SUMMARY, summary
dic_obj_insert_info.Add GB_DEL_FLG, 0
Call insert_info(GB_T_LAW_INFO_TABLE, dic_obj_insert_info, law_info_table_map)
End If
If mode = 2 Then
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'テンポラリーテーブルから更新用のIDを取得
dic_obj_select_info.Add GB_T_ID, 1
Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
id = select_dto.Item(1).Item(GB_ID)
licence_chara = select_dto.Item(1).Item(GB_LICENCE)
category_chara = select_dto.Item(1).Item(GB_CATEGORY)
no_chara = select_dto.Item(1).Item(GB_NUM)
sheetname = licence_chara & "_" & category_chara & "_" & no_chara
t_rate = edit_Form.rate_ComboBox.ListIndex
summary = edit_Form.summary_TextBox
'行列の更新を行う
row = edit_Form.row_TextBox
col = edit_Form.col_TextBox
'更新条件用の入れ物を用意
Dim dic_obj_search_info As Object
Set dic_obj_search_info = CreateObject("Scripting.Dictionary")
dic_obj_search_info.Add GB_ID, id
'更新値用の入れ物を用意
Dim dic_obj_update_info As Object
Set dic_obj_update_info = CreateObject("Scripting.Dictionary")
dic_obj_update_info.Add GB_ROW, row
dic_obj_update_info.Add GB_COL, col
dic_obj_update_info.Add GB_RATE, t_rate
dic_obj_update_info.Add GB_SUMMARY, summary
'更新処理を行う
Call update_info(GB_T_LAW_INFO_TABLE, dic_obj_search_info, dic_obj_update_info, law_info_table_map)
End If
'-------------問題ブック作成-------------
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'ブック作成
newBookName = no_chara & ".xlsx"
savepath = ThisWorkbook.path & "\" & licence_chara & "\" & category_chara & "\" & newBookName
' Debug.Print savepath
Call DeleteSomething
Set newBook = Workbooks.Add
ThisWorkbook.Activate
If mode = 1 Then
ThisWorkbook.Worksheets("問題作成").Copy after:=newBook.Sheets(newBook.Sheets.Count)
ElseIf mode = 2 Then
ThisWorkbook.Worksheets("編集").Copy after:=newBook.Sheets(newBook.Sheets.Count)
End If
newBook.Activate
'1枚目のシート以外は削除する
Dim i As Long
For i = 1 To Worksheets.Count - 1
newBook.Sheets(i).Delete
Next i
' newBook.Sheets("Sheet1").Delete
' newBook.Sheets("Sheet2").Delete
' newBook.Sheets("Sheet3").Delete
'シート名を変更
newBook.Sheets(1).Name = sheetname
'不要な行の削除
' Range("A2", Cells(Rows.Count, 1).End(xlUp)).EntireRow.Delete
'不要なフォームボタンの削除
Dim myShape As Variant
If Worksheets(sheetname).Shapes.Count > 0 Then
For Each myShape In Worksheets(sheetname).Shapes
'図形がフォームボタンなら削除
If myShape.Type = msoFormControl Then
myShape.Delete
End If
Next
End If
newBook.SaveAs savepath
newBook.Close False
Set newBook = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "登録完了です。"
regist_Form.no_TextBox = ""
regist_Form.row_TextBox = ""
regist_Form.col_TextBox = ""
law_Form.law_TextBox = ""
Cells(4, 4).Select
End Function
Sub open_law_Form()
law_Form.Show vbModeless
End Sub
Sub open_regist_form()
regist_Form.Show vbModeless
End Sub
Sub open_fill_chara_form()
fill_chara_Form.Show vbModeless
End Sub
Sub reset_question()
Dim rc As Integer
Dim myShape As Variant
rc = MsgBox("リセットしますか?", vbYesNo + vbQuestion, "確認")
If rc = vbYes Then
'A3行以下、文字、図形を削除
Call delete_all("A3", "問題作成")
' Range("A3", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
'
'
' If ThisWorkbook.Worksheets("問題作成").Shapes.Count > 0 Then
'
' For Each myShape In question_Book.Worksheets(1).Shapes
'
' myShape.Delete
'
' Next
'
' End If
Else
MsgBox "処理を中断します"
End If
End Sub
Function delete_all(delete_row_range As String, sheet_name As String)
'第一引数:ここで指定した行以下を削除 例 "A3"
'第二引数:削除を行いたいシート名を指定
Dim myShape As Variant
'文字情報を削除する
Range(delete_row_range, Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
'画像情報を削除する
If ThisWorkbook.Worksheets(sheet_name).Shapes.Count > 0 Then
For Each myShape In Worksheets(sheet_name).Shapes
'フォームボタンは消さない
If myShape.Type <> msoFormControl Then
myShape.Delete
End If
'フォームボタンの削除について
'https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1155987826
' If myShape.FormControlType <> xlButtonControl Then
'
' myShape.Delete
'
' End If
Next
End If
End Function
Sub test()
'情報登録
Dim dic_obj_select_info As Object
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
Dim select_dto As Object
'存在チェック
dic_obj_select_info.Add GB_LICENCE, "電験三種"
dic_obj_select_info.Add GB_CATEGORY, "電技解釈"
dic_obj_select_info.Add GB_NUM, 1
Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
Debug.Print select_dto.Item(GB_ROW)
End Sub
Sub test_regist()
Dim dic_obj_insert_info As Object
Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
Dim tbList As ListObject
Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
dic_obj_insert_info.Add GB_LICENCE, "電験三種"
dic_obj_insert_info.Add GB_CATEGORY, "電技解釈"
dic_obj_insert_info.Add GB_NUM, "10"
dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1
Call insert_info(GB_T_LAW_INFO_TABLE, dic_obj_insert_info, law_info_table_map)
End Sub
Sub test_update()
Dim dic_obj_update_info As Object
Set dic_obj_update_info = CreateObject("Scripting.Dictionary")
Dim dic_obj_search_info As Object
Set dic_obj_search_info = CreateObject("Scripting.Dictionary")
'検索条件
dic_obj_search_info.Add GB_CATEGORY, "電技解釈"
' dic_obj_search_info.Add GB_ID, 3
'更新値
dic_obj_update_info.Add GB_NUM, 40
dic_obj_update_info.Add GB_ROW, 90
Call update_info(GB_T_LAW_INFO_TABLE, dic_obj_search_info, dic_obj_update_info, law_info_table_map)
End Sub
Sub decompose_string_direct(str)
'入力された文字列をセルに1文字ずつ入れていく
Dim i As Long
Dim row As Long
Dim col As Long
row = 0
col = 1
Application.ScreenUpdating = False
'前の文字
Dim current_char As String
With ActiveCell
' str = .Value
For i = 1 To Len(str)
current_char = Mid(str, i, 1)
If current_char = "/" Then
row = row + 1
col = 1
Else
.Offset(row, col).Value = current_char
col = col + 1
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Function DeleteSomething()
'シートコピー前のおまじない
'何を消してるんだろう?
Dim C As Name
For Each C In Names
C.Delete
Next
End Function
Sub セルに入力された文字列を一文字ずつ横方向に分解する()
'使ってない
Dim str As String
Dim i As Long
Dim row As Long
Dim col As Long
row = 0
col = 1
Dim length_linefeed_chara
'改行文字数
length_linefeed_chara = 30
Dim linefeed_count As Long
'改行を行った回数
linefeed_count = 0
Dim punctuation_mark_flg As Boolean
'句読点フラグ
punctuation_mark_flg = False
Dim blank_chara_start As String
'穴埋め文字が始まるのを判別する文字
blank_chara_start = "["
Dim blank_chara_end As String
'穴埋め文字が終わるのを判別する文字
blank_chara_end = "]"
Dim fill_in_the_blank_chara As String
Dim fill_in_the_blank_chara_count As Long
Dim merge_start As String
Dim merge_end As String
Dim fill_in_the_blank_flg
'穴埋めフラグ 当フラグがONの場合は改行しない
fill_in_the_blank_flg = False
Dim pre_char As String
'前の文字
Dim current_char As String
'今の文字
Dim next_char As String
'次の文字
Dim active_address_char As String
With ActiveCell
str = .Value
For i = 1 To Len(str)
punctuation_mark_flg = False
current_char = Mid(str, i, 1)
If i > 1 Then
pre_char = Mid(str, i - 1, 1)
next_char = Mid(str, i + 1, 1)
If current_char = blank_chara_start Then
fill_in_the_blank_flg = True
'ディクショナリを宣言
Dim dictionary_object_coordinate As Object
Set dictionary_object_coordinate = CreateObject("Scripting.Dictionary")
fill_in_the_blank_chara_count = 1
End If
If fill_in_the_blank_flg = True And current_char = blank_chara_end Then
fill_in_the_blank_flg = False
End If
'穴埋めの文字列の間は改行しない
If fill_in_the_blank_flg = False Then
'イロハニ問答無用で改行
If current_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ,ル]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
'漢数字ニ桁で改行
If current_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) And pre_char Like "[一,ニ,三,四,五,六,七,八,九,十]" Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
'漢数字一桁で改行
If current_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
If (i > length_linefeed_chara And Not current_char Like "[あ-ん]") And pre_char Like "[あ-ん]" Then
.Offset(1, 0).Select
row = row + 1
col = 1
If current_char = "、" Or current_char = "。" Then
punctuation_mark_flg = True
End If
length_linefeed_chara = i + 30
End If
End If
End If
next_loop:
If punctuation_mark_flg = False Then
.Offset(row, col).Value = current_char
If fill_in_the_blank_flg = True Then
fill_in_the_blank_chara = fill_in_the_blank_chara + current_char
' Debug.Print .Offset(row, col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
'ディクショナリに文字座標をブッ込んでいく
dictionary_object_coordinate.Add fill_in_the_blank_chara_count, .Offset(row, col).Address(RowAbsolute:=False, ColumnAbsolute:=False)
fill_in_the_blank_chara_count = fill_in_the_blank_chara_count + 1
End If
'current_charが"]"だったら、各種処理を行う
'穴埋めセルの結合
'穴埋め文字始めの座標の登録
'穴埋め文字の登録
'ジャンル(ID、電験三種、電気事業法、一条、予備、予備)座標、穴埋め文字列をセットで登録する
'一条までは共通、以下座標ごとに個別
If current_char = blank_chara_end Then
merge_start = dictionary_object_coordinate.Item(2)
merge_end = .Offset(row, col - 1).Address(RowAbsolute:=False, ColumnAbsolute:=False)
Worksheets("問題展開").Range(merge_start & ":" & merge_end).Merge
Range(dictionary_object_coordinate.Item(2)).Value = Mid(fill_in_the_blank_chara, 2)
merge_start = ""
merge_end = ""
End If
col = col + 1
End If
Next i
End With
Debug.Print Mid(fill_in_the_blank_chara, 2)
End Sub
Sub pattern_test()
'使用していない
Dim str As String
' str = "ニ"
'
' If str Like "[イ,ロ,ハ,ニ]" Then
'
' Debug.Print str
'
' End If
str = "小売供給 一般の需要に"
If InStr(str, "") Then
Debug.Print "全角スペースだぜ"
End If
End Sub
Sub merge_cells()
'使用していない
Dim a As String
Dim b As String
Dim str As String
Range("A1").Select
a = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Worksheets("Sheet1").Range(a & ":B1").Merge
End Sub
Function get_kanji(str As String)
'使用していない
Dim kanji_flg As Boolean
kanji_flg = False
Dim kanji As String
Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "[一-龠〃々〆〇]"
For i = 1 To Len(str)
current_char = Mid(str, i, 1)
If reg.test(current_char) Then
kanji_flg = True
End If
If reg.test(current_char) = False Then
kanji_flg = False
End If
If kanji_flg = True Then
kanji = kanji + current_char
End If
If kanji_flg = False Then
If Len(kanji) > 1 Then
Debug.Print kanji
End If
kanji = ""
End If
Next i
End Function
Sub decompose_string(str)
'使用していません
' Dim str As String
Dim i As Long
Dim row As Long
Dim col As Long
row = 0
col = 1
Dim reg As Object
Set reg = CreateObject("VBScript.RegExp")
reg.Pattern = "[一-龠〃々〆〇]"
Dim length_linefeed_chara
'改行文字数
length_linefeed_chara = 30
Dim linefeed_count As Long
'改行を行った回数
linefeed_count = 0
Dim punctuation_mark_flg As Boolean
'句読点フラグ
punctuation_mark_flg = False
Dim blank_chara_start As String
'穴埋め文字が始まるのを判別する文字
blank_chara_start = "["
Dim blank_chara_end As String
'穴埋め文字が終わるのを判別する文字
blank_chara_end = "]"
Dim fill_in_the_blank_chara As String
Dim fill_in_the_blank_chara_count As Long
Dim merge_start As String
Dim merge_end As String
Dim fill_in_the_blank_flg
'穴埋めフラグ 当フラグがONの場合は改行しない
fill_in_the_blank_flg = False
Dim pre_char As String
'前の文字
Dim current_char As String
'今の文字
Dim next_char As String
'次の文字
Dim next_next_char As String
'次の次の文字
'次の次の次の文字
Dim next_next_next_char As String
Dim active_address_char As String
With ActiveCell
' str = .Value
For i = 1 To Len(str)
punctuation_mark_flg = False
current_char = Mid(str, i, 1)
If i > 1 Then
pre_char = Mid(str, i - 1, 1)
next_char = Mid(str, i + 1, 1)
next_next_char = Mid(str, i + 2, 1)
next_next_next_char = Mid(str, i + 3, 1)
'穴埋めの文字列の間は改行しない
If fill_in_the_blank_flg = False Then
'イロハニ問答無用で改行
If current_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) Then
.Offset(1, 0).Select
row = row + 1
col = 2
length_linefeed_chara = i + 30
GoTo next_loop
End If
'漢数字三桁で改行
If current_char Like "[一,二,三,四,五,六,七,八,九]" And next_char Like "[十]" And next_next_char Like "[一,二,三,四,五,六,七,八,九]" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
'漢数字ニ桁で改行
If current_char Like "[一,二,三,四,五,六,七,八,九,十]" And next_char Like "[一,二,三,四,五,六,七,八,九,十]" And (InStr(next_next_char, " ") = 1 Or InStr(next_next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
'漢数字一桁で改行
If current_char Like "[一,二,三,四,五,六,七,八,九,十]" And (InStr(next_char, " ") = 1 Or InStr(next_char, " ") = 1) And Not pre_char Like "[一,二,三,四,五,六,七,八,九,十]" Then
.Offset(1, 0).Select
row = row + 1
col = 1
length_linefeed_chara = i + 30
GoTo next_loop
End If
'(イロハニ)で改行
If current_char = "(" And next_char Like "[イ,ロ,ハ,ニ,ホ,ヘ,ト,チ,リ,ヌ]" And next_next_char = ")" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) Then
.Offset(1, 0).Select
row = row + 1
col = 2
length_linefeed_chara = i + 30
GoTo next_loop
End If
'(123456789)で改行
If current_char = "(" And next_char Like "[1,2,3,4,5,6,7,8,9]" And next_next_char = ")" And (InStr(next_next_next_char, " ") = 1 Or InStr(next_next_next_char, " ") = 1) Then
.Offset(1, 0).Select
row = row + 1
col = 2
length_linefeed_chara = i + 30
GoTo next_loop
End If
If i > length_linefeed_chara And (pre_char = "、" Or pre_char = "。") Then
.Offset(1, 0).Select
row = row + 1
col = 2
length_linefeed_chara = i + 30
End If
If i > length_linefeed_chara And current_char Like "[あ-ん]" Then
.Offset(1, 0).Select
row = row + 1
col = 2
length_linefeed_chara = i + 30
End If
End If
End If
next_loop:
.Offset(row, col).Value = current_char
If current_char <> "" Then
col = col + 1
End If
Next i
End With
End Sub
Sub get_keisen()
Dim bs As Borders
Set bs = Range("D16", "AN20").Borders
Debug.Print (bs.LineStyle)
Debug.Print (bs.Weight)
End Sub
●module2
Option Explicit
Sub select_question()
'ランダムで選ばれたブックを開く
Dim id As Long
Dim select_dto As Object
Dim tbList As ListObject
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'------------------------超手抜き 連番で攻略したいの
Dim setter_number As Object
Dim getter_number As Object
Dim sequence_flg As Boolean
Dim setter_number_update As Object
sequence_flg = False
Dim sequence_num As Long
Set setter_number = CreateObject("Scripting.Dictionary")
setter_number.Add GB_T_ID, 1
Set getter_number = select_info(GB_T_NUMBER_TABLE, setter_number, number_table_map)
Debug.Print getter_number.Item(1).Item(GB_NUMBER1)
'number_tableの値を0にしておけばランダム出題になる
If getter_number.Item(1).Item(GB_NUMBER1) > 0 Then
id = getter_number.Item(1).Item(GB_NUMBER1)
sequence_num = getter_number.Item(1).Item(GB_NUMBER1)
'連番でやる意欲を感じるぜ
sequence_flg = True
Set setter_number = Nothing
Set getter_number = Nothing
Else
'ランダム出題
'------------------------law_info_tableから問題呼び出し--------------------------
'-------------------------------------------
' Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
' Randomize '乱数系列初期化
' id = Int(tbList.ListRows.Count * Rnd + 1)
'-------------------------------------------
'idをサイクルで取得する
Dim obj_subjects As Object
'科目を決められたサイクルで選び出す
Set obj_subjects = selectSubjects()
id = returnRndIdWithCategory(obj_subjects)
End If
'問題情報を各ブックから取得し演習シートにコピペ
Set select_dto = get_question(id, "演習")
'------------------------temporaryテーブルに問題の情報登録--------------------------
Set tbList = Worksheets(GB_T_TEMPORARY_TABLE).ListObjects(GB_T_TEMPORARY_TABLE)
'既存情報削除(レコードがない状態で行うとエラー)
If tbList.ListRows.Count > 0 Then
tbList.DataBodyRange.Delete
End If
'現在展開している問題の把握のため 問題の穴埋め箇所の更新等に利用
Dim dic_obj_insert_info As Object
Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
dic_obj_insert_info.Add GB_T_ID, 1
dic_obj_insert_info.Add GB_ID, select_dto.Item(1).Item(GB_ID)
dic_obj_insert_info.Add GB_LICENCE, select_dto.Item(1).Item(GB_LICENCE)
dic_obj_insert_info.Add GB_CATEGORY, select_dto.Item(1).Item(GB_CATEGORY)
dic_obj_insert_info.Add GB_NUM, select_dto.Item(1).Item(GB_NUM)
dic_obj_insert_info.Add GB_ROW, select_dto.Item(1).Item(GB_ROW)
dic_obj_insert_info.Add GB_COL, select_dto.Item(1).Item(GB_COL)
dic_obj_insert_info.Add GB_RATE, select_dto.Item(1).Item(GB_RATE)
dic_obj_insert_info.Add GB_SUMMARY, select_dto.Item(1).Item(GB_SUMMARY)
dic_obj_insert_info.Add GB_TEXT, select_dto.Item(1).Item(GB_TEXT)
Call insert_info(GB_T_TEMPORARY_TABLE, dic_obj_insert_info, temporary_table_map)
'------------------------問題解析--------------------------
Sheets("演習").Activate
Call register_fill_in_the_blank_character(select_dto.Item(1).Item(GB_ROW), select_dto.Item(1).Item(GB_COL))
Range("T2").Value = select_dto.Item(1).Item(GB_CATEGORY)
Set setter_number = CreateDictionary
Set setter_number_update = CreateDictionary
'連番で解答したいの
If sequence_flg = True Then
'カウントアップ
sequence_num = sequence_num + 1
setter_number.Add (GB_T_ID), 1
setter_number_update.Add (GB_NUMBER1), sequence_num
Call update_info(GB_T_NUMBER_TABLE, setter_number, setter_number_update, number_table_map)
sequence_flg = False
End If
Dim times As Long
times = select_dto.Item(1).Item(GB_C_TIMES)
'サイクル用に解答回数+1
Dim setter_target As Object
Dim setter_value As Object
Set setter_target = CreateDictionary
Set setter_value = CreateDictionary
setter_target.Add GB_ID, id
setter_value.Add GB_C_TIMES, times + 1
Call update_info(GB_T_LAW_INFO_TABLE, setter_target, setter_value, law_info_table_map)
'サイクルカウントアップ
Call updateCycleNO
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function register_fill_in_the_blank_character(last_row As Long, last_col As Long)
'[]でくくられている文字とセル座標を取得し登録する
Dim tbList As ListObject
Set tbList = Worksheets(GB_T_FILL_WORD_TABLE).ListObjects(GB_T_FILL_WORD_TABLE)
'既存情報削除(レコードがない状態で行うとエラー)
If tbList.ListRows.Count > 0 Then
tbList.DataBodyRange.Delete
End If
Dim i As Long
Dim j As Long
Dim fill_flg As Boolean
Dim start_address As String
Dim str As String
fill_flg = False
For i = 1 To last_row
For j = 1 To last_col
If fill_flg = True Then
'Debug.Print Cells(i, j).Value
str = str & Cells(i, j).Value
End If
If Cells(i, j).Value = "[" Then
start_address = Cells(i, j + 1).Address(False, False)
fill_flg = True
End If
If Cells(i, j + 1).Value = "]" Then
Range(start_address & ":" & Cells(i, j).Address(False, False)).Merge
Range(start_address).Value = ""
Range(start_address).Interior.ColorIndex = 19
Dim dic_obj_insert_info As Object
Set dic_obj_insert_info = CreateObject("Scripting.Dictionary")
dic_obj_insert_info.Add GB_ID, tbList.ListRows.Count + 1
dic_obj_insert_info.Add GB_PLACE, start_address
dic_obj_insert_info.Add GB_WORD, str
Call insert_info(GB_T_FILL_WORD_TABLE, dic_obj_insert_info, fill_word_table_map)
start_address = ""
str = ""
fill_flg = False
End If
Next j
Next i
End Function
Sub edit_question()
'問題の編集を行う
'temporaryから問題情報取得
'問題作成シートに展開
Dim select_dto As Object
Dim question_info_dto As Object
Dim dic_obj_select_info As Object
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'------------------------temporary_table--------------------------
'一時テーブルから現在展開されている問題情報を取得する
dic_obj_select_info.Add GB_T_ID, 1
Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
'初期化
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
'------------------------law_info_table-------------------------
'law_info_tableから情報を取得する
dic_obj_select_info.Add GB_ID, select_dto.Item(1).Item(GB_ID)
Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
'問題を呼び出す
Set question_info_dto = get_question(select_dto.Item(1).Item(GB_ID), "編集")
ThisWorkbook.Save
Set question_info_dto = Nothing
End Sub
Function get_question(id As Long, sheet_name As String) As Object
'問題を呼び出す関数
'第一引数 id
'第二引数 呼び出した問題を展開するシート名
'呼ばれるタイミング
Dim question_Book As Workbook
Dim licence_chara As String
Dim category_chara As String
Dim question_path As String
Dim num As Variant
Dim row As Long
Dim col As Long
Dim select_dto As Object
Dim dic_obj_select_info As Object
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Worksheets(sheet_name).Activate
'既存削除
' Worksheets(sheet_name).Range("A3", Cells(Rows.Count, 1).End(xlDown)).EntireRow.Delete
Call delete_all("A3", sheet_name)
dic_obj_select_info.Add GB_ID, id
Set select_dto = select_info(GB_T_LAW_INFO_TABLE, dic_obj_select_info, law_info_table_map)
licence_chara = select_dto.Item(1).Item(GB_LICENCE)
category_chara = select_dto.Item(1).Item(GB_CATEGORY)
num = select_dto.Item(1).Item(GB_NUM)
row = select_dto.Item(1).Item(GB_ROW)
col = select_dto.Item(1).Item(GB_COL)
question_path = ThisWorkbook.path & "\" & licence_chara & "\" & category_chara & "\" & num
Set question_Book = Workbooks.Open(question_path, 3)
'文字情報の貼り付け
question_Book.Worksheets(1).Range(Cells(3, 1), Cells(row, col)).Copy
ThisWorkbook.Activate
Worksheets(sheet_name).Cells(3, 1).PasteSpecial xlPasteAll
'画像情報の貼り付け
'穴埋め問題ジェネレーター.xlsmの演習シートが選択されている
Dim myShape As Variant
If question_Book.Worksheets(1).Shapes.Count > 0 Then
For Each myShape In question_Book.Worksheets(1).Shapes
myShape.Copy
ActiveSheet.Paste
'myShape.Top+30等で貼り付ける位置を調整できる
Selection.Top = myShape.Top
Selection.Left = myShape.Left
Next
End If
Worksheets(sheet_name).Activate
Worksheets(sheet_name).Cells(3, 1).Select
'ThisWorkbook.Save
question_Book.Close savechanges:=False
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set get_question = select_dto
End Function
Sub open_edit_form()
Dim select_dto As Object
Dim dic_obj_select_info As Object
Set dic_obj_select_info = CreateObject("Scripting.Dictionary")
Dim t_rate As Long
dic_obj_select_info.Add GB_T_ID, 1
Set select_dto = select_info(GB_T_TEMPORARY_TABLE, dic_obj_select_info, temporary_table_map)
' Debug.Print select_dto.Item(1).Item(GB_LICENCE)
edit_Form.licence_TextBox = select_dto.Item(1).Item(GB_LICENCE)
edit_Form.category_TextBox = select_dto.Item(1).Item(GB_CATEGORY)
edit_Form.no_TextBox = select_dto.Item(1).Item(GB_NUM)
edit_Form.row_TextBox = select_dto.Item(1).Item(GB_ROW)
edit_Form.col_TextBox = select_dto.Item(1).Item(GB_COL)
edit_Form.rate_ComboBox.ListIndex = select_dto.Item(1).Item(GB_RATE)
edit_Form.summary_TextBox = select_dto.Item(1).Item(GB_SUMMARY)
edit_Form.text_TextBox = select_dto.Item(1).Item(GB_TEXT)
edit_Form.licence_TextBox.Enabled = False
edit_Form.category_TextBox.Enabled = False
edit_Form.no_TextBox.Enabled = False
edit_Form.Show vbModeless
End Sub
Sub open_text()
'---------------------temporary_tableからテキストページを取得
Dim text_page As Long
Dim setter As Object
Dim getter As Object
Set setter = CreateObject("Scripting.Dictionary")
Set getter = CreateObject("Scripting.Dictionary")
setter.Add GB_T_ID, 1
Set getter = select_info(GB_T_TEMPORARY_TABLE, setter, temporary_table_map)
text_page = getter.Item(1).Item(GB_TEXT)
Dim path As String
Dim xClip
Set xClip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
'クリップボードに開きたいPDFのページ数をコピー
xClip.SetText text_page
xClip.PutInClipboard
'まさかの決め打ち
path = ThisWorkbook.path & "\電験三種\テキスト\電験三種のエロ本応用編.pdf"
'pdfファイルを開く
With CreateObject("Wscript.Shell")
.Run path, 5
End With
With Application
.Wait Now + TimeValue("00:00:01")
.SendKeys "^+N", True 'CTRL+SHIF+Nを押す
.Wait Now + TimeValue("00:00:01")
.SendKeys "^v", True 'CTRL+Vを押す
.SendKeys "~", True 'エンターを押す
End With
End Sub
Function selectSubjects() As Object
'決められたサイクルで科目名を返却する
'サイクル番号はnumber_tableのcycle_noを使う
Dim setter As Object
Dim getter_subjects As Object
Dim getter_cycle_no As Object
Dim i As Long
Dim dto_subjects
Set dto_subjects = CreateDictionary
Set setter = CreateDictionary
'サイクルリストの条件
setter.Add GB_ID, "*"
'サイクルリストを取得する
Set getter_subjects = select_info(GB_T_QUESTION_CYCLE_TABLE, setter, question_cycle_table_map)
Set setter = Nothing
Set setter = CreateDictionary
' Debug.Print "selectSubjects.getter_subjects" & getter_subjects.Count
setter.Add GB_T_ID, 1
'現在のサイクル番号を取得する
Set getter_cycle_no = select_info(GB_T_NUMBER_TABLE, setter, number_table_map)
' Debug.Print "selectSubjects.getter_cycle_no" & getter_cycle_no.Count
For i = 1 To getter_subjects.Count
If getter_subjects.Item(i).Item(GB_C_ID) = getter_cycle_no.Item(1).Item(GB_NUMBER2) Then
dto_subjects.Add GB_LICENCE, getter_subjects.Item(i).Item(GB_LICENCE)
dto_subjects.Add GB_C_SUB_CATEGORY, getter_subjects.Item(i).Item(GB_C_SUB_CATEGORY)
dto_subjects.Add GB_C_TIMES, getter_subjects.Item(i).Item(GB_C_TIMES)
' Debug.Print "資格" & getter_subjects.Item(i).Item(GB_LICENCE)
' Debug.Print "カテゴリ" & getter_subjects.Item(i).Item(GB_C_SUB_CATEGORY)
' Debug.Print "回数" & getter_subjects.Item(i).Item(GB_C_TIMES)
Exit For
End If
Next i
Set selectSubjects = dto_subjects
End Function
Function updateCycleNO()
'今のサイクルNOをカウントアップする
'サイクル番号はmemory_tableのslot1を使う
Dim cycleNo As Long
Dim setter As Object
Dim setter_target As Object
Dim setter_value As Object
Dim getter_subjects As Object
Dim getter_cycle_no As Object
Set setter = CreateDictionary
Set setter_target = CreateDictionary
Set setter_value = CreateDictionary
setter.Add GB_ID, "*"
'サイクルリストを取得する
Set getter_subjects = select_info(GB_T_QUESTION_CYCLE_TABLE, setter, question_cycle_table_map)
Debug.Print getter_subjects.Count
Set setter = Nothing
Set setter = CreateDictionary
setter.Add GB_T_ID, 1
'現在のサイクル番号を取得する
Set getter_cycle_no = select_info(GB_T_NUMBER_TABLE, setter, number_table_map)
If getter_cycle_no.Item(1).Item(GB_NUMBER2) < getter_subjects.Count Then
cycleNo = getter_cycle_no.Item(1).Item(GB_NUMBER2) + 1
setter_target.Add GB_T_ID, 1
setter_value.Add GB_NUMBER2, cycleNo
Else
cycleNo = 1
setter_target.Add GB_T_ID, 1
setter_value.Add GB_NUMBER2, cycleNo
End If
Call update_info(GB_T_NUMBER_TABLE, setter_target, setter_value, number_table_map)
End Function
Function returnRndIdWithCategory(subjects As Object) As Long
'選択科目の問題からランダムにIDを返却する
Dim setter As Object
Dim getter As Object
Set setter = CreateDictionary
'資格名を設定する
setter.Add GB_LICENCE, subjects.Item(GB_LICENCE)
' Debug.Print "◇名" & subjects.Item(GB_LICENCE)
'カテゴリーが設定されていたら、条件に追加する
If subjects.Item(GB_C_SUB_CATEGORY) <> "" Then
setter.Add GB_C_SUB_CATEGORY, subjects.Item(GB_C_SUB_CATEGORY)
End If
' Debug.Print "カテゴリ" & subjects.Item(GB_C_SUB_CATEGORY)
'回数が設定されていたら 未出題に限定したいとき
If subjects.Item(GB_C_TIMES) <> "" Then
setter.Add GB_C_TIMES, subjects.Item(GB_C_TIMES)
End If
' MsgBox subjects.Item(GB_C_TIMES)
Set getter = select_info(GB_T_LAW_INFO_TABLE, setter, law_info_table_map)
If getter.Count = 0 Then
MsgBox "サイクルモードで科目または、カテゴリー設定に誤りがあります"
End
End If
' Debug.Print "カウント" & getter.Count
'ランダム番号を取得する
Dim randomNumber As Long
Randomize
randomNumber = Int(getter.Count * Rnd) + 1
' Debug.Print randomNumber
returnRndIdWithCategory = getter.Item(randomNumber).Item(GB_C_ID)
End Function
Sub randtest()
Dim tbList As ListObject
Set tbList = Worksheets(GB_T_LAW_INFO_TABLE).ListObjects(GB_T_LAW_INFO_TABLE)
Randomize '乱数系列初期化
Debug.Print Int(tbList.ListRows.Count * Rnd + 1) '1~6で乱数生成
End Sub
Sub longtest()
Dim a As Long
Dim b As Long
If IsEmpty(a) Then
Debug.Print "なんもないよ"
Else
Debug.Print a
End If
End Sub
Sub cycle_test()
Dim setter As Object
Dim getter As Object
Set setter = CreateDictionary
setter.Add GB_LICENCE, "消防4類乙"
Set getter = select_info(GB_T_LAW_INFO_TABLE, setter, law_info_table_map)
Debug.Print getter.Count
Debug.Print getter.Count
End Sub
●各ボタン
★問題作成シート
問題作成:open_law_form
穴埋め:open_fill_chara_form
問題登録:open_regist_form
リセット:reset_question
★演習シート
問題ガチャ:select_question
編集:edit_question
テキスト:open_text
★編集シート
問題作成:open_law_form
穴埋め:open_fill_chara_form
再登録する:open_edit_form
問題ガチャ:select_question
テキスト:open_text