NotesDBへExcelデータを一括インポート（Create＆Update）(当ロジック実行後、対象文書にToolsRefreshSelectedDocsを掛けること)

Option Public
Option Declare



Dim Gc_ss 			As NotesSession
Dim Gc_db 			As NotesDatabase


Sub Initialize
	
	Set Gc_ss		= New NotesSession
	Set Gc_db 		= Gc_ss.CurrentDatabase	
	
	Call ImportExcelFileFromHinagata()
End Sub




Function ImportExcelFileFromHinagata() As Integer
	
	On Error Goto RunTimeErr
	ImportExcelFileFromHinagata = False
	
	'当ＤＢ内に含まれる、文書をExcelにエクスポートする。
	'（※特定条件のみ。条件は、Excel元ファイルに既述。）
	'【注）；現在、複数値については、テキストデータにのみ、対応しています。】
	
	'1).宣言
	Dim L_uiwork 			As New NotesUIWorkSpace
	Dim UpDb				As NotesDatabase
	Dim vewSearch 		As notesview	
	Dim colUp				As NotesDocumentCollection		
	Dim docUp 			As notesdocument	
	Dim itmUp 				As notesitem		
	Dim XSheet			As Variant
	Dim XBook				As Variant
	Dim XObj				As Variant		
	Dim strFldNm			As String
	Dim strLabel			As String	
	Dim strType			As String	
	Dim strKey				As String		
	Dim L					As Long
	Dim ArrCount			As Long
	Dim DefP				As Long	
	Dim Lp_row 			As Long
	Dim Lp_clm 			As Long	
	Dim BufValue 			As String
	Dim KeyMatchCount 	As Double
	Dim intErrPoint			As Integer
	Dim InputFileNm		As Variant
	Dim intRet				As Integer
	Dim key_count			As Long
	Dim List_count			As Integer
	Dim varList				As Variant
	Dim FmNm				As String
	Dim countCre			As Double
	Dim countUp			As Double
	
	
	'2).初期設定	
	
	DefP			= 10-1
	ArrCount		= -1
	key_count		= -1
	countCre		= 0
	countUp		= 0
	
	'対象サーバーの指定
	Dim ret1 As String
	ret1=Inputbox("対象サーバー","対象サーバーを指定してください。")
	If ret1="" Then
		Goto ObjNull	
	End If
	If ret1="Local" Or ret1="local" Then
		ret1=""
	End If
	
	'対象DBの指定
	Dim ret2 As String
	ret2=Inputbox("対象DBファイルパス","対象DBのファイルパスを指定してください。")
	If ret2="" Then
		Goto ObjNull	
	End If
	
	'IsOpen
	Set UpDb=Gc_ss.GetDatabase(ret1,ret2)
	If UpDb.IsOpen=False Then
		Msgbox "対象DBが取得できませんでした！",0+16,"Error"
		Goto ObjNull	
	End If
	
	'最終確認	
	Dim ret4 As Integer
	ret4=Messagebox("下記のDBを更新します。よろしですか？"+Chr(13)+Chr(13)+"サーバー："+ret1+Chr(13)+"DBファイルパス："+ret2,4 + 32,"最終確認")	
	If ret4=7 Then
		Goto ObjNull		
	End If
	
	
	'該当ファイルの選択ダイアログボックスの表示
	InputFileNm = L_uiwork.OpenFileDialog(False,"インポートする "+"マスターを選択して下さい。","確認","")
	
	If (Isempty(InputFileNm)) Then
		Goto ObjNull
	End If	
	
	intRet 	= Msgbox("本当に、"+"マスター（"+Cstr(InputFileNm(0))+"）をインポートしますか？",48+4,"最終確認")
	If intRet = 7 Then
		Goto ObjNull
	End If	
	
	
	'''Msgbox "注）：新規作成時のみ、『ComputeWithForm』コマンドが、有効になります！"
	
	
	Dim fileNum	As Integer	
	Dim PathText	As String	
	fileNum% 			= 1
	PathText			="c:\temp\CommonDesignImport Create ("+Format$(Now(),"yyyymmdd hhmmss")+").csv"	
	Open PathText For Output As fileNum%	
	
	Dim fileNum2	As Integer	
	Dim PathText2	As String	
	fileNum2% 			= 2
	PathText2			="c:\temp\CommonDesignImport Update ("+Format$(Now(),"yyyymmdd hhmmss")+").csv"	
	Open PathText2 For Output As fileNum2%	
	
	
	'雛形ファイルがオープン中かどうかを判断
	'オープンされていなければ、オープンする。		
	intErrPoint		= 1			'/【エラーポイントOn】
	Set XObj 				= CreateObject("Excel.Application")
	XObj.DisplayAlerts		= False	
	XObj.Visible 			= False	
	'外部ファイルの読み込み	
	Set XBook				= XObj.Workbooks.Open(InputFileNm(0))
	XBook.Saved			= True
	Set XSheet 			= XBook.Worksheets("パラメータ")
	XSheet.Activate
	'6).インポート対象フィールドを、変数に格納
	L					= DefP
	Do While (True)
		L				= L+1
		strFldNm		= XSheet.Cells(L,3).Value
		strLabel		= XSheet.Cells(L,2).Value
		strKey			= XSheet.Cells(L,4).Value		
		strType			= XSheet.Cells(L,5).Value		
		If strFldNm		= "" Then
			Exit Do			
		End If		
		ArrCount		= ArrCount+1
		Redim Preserve ArrFldNm(ArrCount) As String
		Redim Preserve ArrLabel(ArrCount) As String		
		Redim Preserve ArrType(ArrCount) As String
		
		If strKey="○" Then
			key_count=key_count+1
			Redim Preserve KeyValue(key_count) As String
		End If		
		
		ArrFldNm(ArrCount)	= strFldNm
		ArrLabel(ArrCount)		= strLabel		
		ArrType(ArrCount)		= strType
	Loop		
	
	'7).サーチ用ビューの取得
	Set vewSearch				= UpDb.GetView(XSheet.Cells(4,3).Value)
	If (vewSearch Is Nothing) Then
		Msgbox "サーチ用ビューが見つかりません。"+Chr(13)_
		+"インポートファイルデータのパラメータシート（通常非表示）の「インポート時におけるKeyサーチ用ビュー」"	+Chr(13)_
		+"の設定が正しいかどうかを確認して下さい。",64+0,"確認"
		Goto ObjNull
	End If
	FmNm						= Trim(XSheet.Cells(5,3).Value)
	
	Set XSheet 				= XBook.Worksheets("Data")
	XSheet.Activate
	
	key_count					= -1
	Lp_row				= 1	
	'8).実値をインポートする
	Do While(True)
		Lp_row			= Lp_row+1
		Lp_clm			= 0
		'ループの終了条件
		'Forall o3 In KeyValue
		'	KeyValue				
		'End Forall
		
		'KeyValue		= Cstr(XSheet.Cells(Lp_row,1).Value)
		If Cstr(XSheet.Cells(Lp_row,1).Value)		= "" Then
			Exit Do
		End If
		'新規作成 or 更新の判断
		key_count					= -1
		Forall o3 In KeyValue
			key_count				= key_count+1
			KeyValue(key_count)	= Cstr(XSheet.Cells(Lp_row,key_count+1).Value)
		End Forall
		
		'''Msgbox(KeyValue(0))
		
		Set colUp			= vewSearch.GetallDocumentsByKey(KeyValue,True)
		KeyMatchCount	= colUp.count
		
		'''Msgbox(Cstr(KeyMatchCount))
		
		
		If KeyMatchCount > 1 Then
			Msgbox "Key："+Join(KeyValue,",")+"に該当するマスター文書が複数あるため、正常に更新できませんでした。"_
			+Chr(13)+"Notes側のデータおよび、Excelデータを確認して下さい。",64+0,"確認"
			Goto ObjNull
		End If
		'文書の新規作成
		If KeyMatchCount=0 Then
			Set docUp=New NotesDocument(UpDb)
			docUp.Form=FmNm
		'更新先文書の取得	
		Else
			Set docUp=colUp.GetFirstDocument
		End If
		
		'フィールドの更新（複数値リストの対応は後回し）
		Forall o2 In ArrFldNm
			Lp_clm			= Lp_clm+1			
			
			If o2<>"*" Then
			'フィールドの削除
				Call docUp.RemoveItem(Cstr(o2))
				BufValue		= Cstr(XSheet.Cells(Lp_row,Lp_clm).Value)
			'フィールドの作成、更新
				Select Case ArrType(Lp_clm-1)
				Case "t"		'テキスト
				'/初回のみフィールドを、属性付きで生成
					List_count			= 0
					varList				= Split(BufValue,Chr(10))
					Forall o5 In varList
						If List_count	= 0 Then
							Set itmUp	= New NotesItem(docUp,Cstr(o2),Cstr(O5))
						Else
							Call itmUp.AppendToTextList(Cstr(o5))
						End If				
						List_count		= List_count+1
					End Forall
				Case "n"		'名前				
					Set itmUp	= New NotesItem(docUp,Cstr(o2),BufValue,Names)						
				Case "s"		'数値
					If BufValue		= "" Then
						Set itmUp	= New NotesItem(docUp,Cstr(o2),"")
					Else
						Set itmUp	= New NotesItem(docUp,Cstr(o2),Cdbl(BufValue))
					End If				
				Case "h"		'日付
					If BufValue		= "" Then
						Set itmUp	= New NotesItem(docUp,Cstr(o2),"")
					Else
						Dim ndt As New Notesdatetime(BufValue)
						Call docUp.ReplaceItemvalue(Cstr(o2),ndt)
						Set ndt			= Nothing	
					End If
				Case "hj"		'日付 + 時刻
					If BufValue		= "" Then
						Set itmUp	= New NotesItem(docUp,Cstr(o2),"")
					Else
						Set itmUp	= New NotesItem(docUp,Cstr(o2),Cdat(Cstr(XSheet.Cells(Lp_row,Lp_clm).Value)))
					End If				
				End Select
				itmUp.IsSummary = True
			End If	
			
		End Forall		
		
		'新規のときのみ、フォーム更新
		If KeyMatchCount		=0 Then
			Call docUp.Save(True,True)	
			'''Call docUp.ComputeWithForm(False,False)	
		End If
		
		'文書の保存
		Call docUp.Save(True,True)		
		
		If KeyMatchCount		=0 Then
			countCre			=countCre+1
			Print #fileNum%,Join(KeyValue,",")
		Else
			countUp			=countUp+1
			Print #fileNum2%,Join(KeyValue,",")
		End If
		
		Print Cstr(Lp_row-1)+" 件 終了"
	Loop
	
	Msgbox "Import/Update 処理は、正常に終了しました！"+Chr(13)+Chr(13)_
	+"詳細ログは、c:\temp\直下の Create 及び Update に関するログを確認して下さい。",64+0,"確認"
	
	'8).オブジェクトの初期化	
	ImportExcelFileFromHinagata = True
ObjNull:	
	If intErrPoint = 1 Then		
		XBook.Saved=True
		XBook.Close
		XObj.Quit		
	End If
	Close fileNum%
	Close fileNum2%
	Set L_uiwork 		= Nothing
	Set vewSearch 	= Nothing
	Set colUp			= Nothing
	Set docUp 			= Nothing
	Set itmUp 			= Nothing
	Set XSheet			= Nothing
	Set XBook			= Nothing
	Set XObj			= Nothing
	Exit Function
	
RunTimeErr:	
	Msgbox "マスターレコード、Excel インポート (agCommonDesignImport) (ImportExcelFileFromHinagata) ｴﾗｰ行" & Cstr(Erl) & " ｴﾗｰ番号" & Trim$(Str(Err)) & "：" & Error$,64+0,"確認"
	If intErrPoint = 1 Then		
		XBook.Saved=True
		XBook.Close
		XObj.Quit		
	End If	
	Close fileNum%
	Close fileNum2%
	Exit Function	
	
End Function