ACL書き出し

Sub Initialize
	
	Dim ss As New NotesSession
	Dim db As NotesDatabase
	Dim uiwork As New NotesUIWorkspace
	Dim damidoc As NotesDocument
	Dim flag As Integer
	Dim wkinfo As String
	Dim wkvari As Variant
	Dim i As Integer
	Dim wkserver As String
	Dim wkpath As String
	Dim Odb As NotesDatabase
	Dim NamesDb As NotesDatabase
	Dim NamesView As NotesView
	Dim NamesDoc		As NotesDocument
	
	
	Set db=ss.CurrentDatabase
	
	Dim acl As NotesACL
	Dim aEntry As NotesACLEntry
	
	Dim fileNum			As Integer
	Dim PathText			As String	
	Dim wktype				As String
	Dim aclArray			As Variant
	Dim roleinfo			As String
	Dim wkCanRepC		As String
	Dim wkCanDelD		As String
	Dim wkCanCD			As String
	Dim wklevel			As String
	Dim wkGpMember		As String
	Dim allArray			As Variant
	Dim strNow			As String
	Dim PathExcel			As String
	
	'ポップアップにて、サーバー名指定	
	Set damidoc=New NotesDocument(db)
	
	flag 		= uiwork.DialogBox("ACL CSV書き出し ダイアログ",True, True ,,,,,"確認",damidoc,True)
	If flag=False Then
		Exit Sub
	End If
	
	fileNum% 				= Freefile()
	strNow					=Cstr(Now())
	PathText				="c:\temp\ACL CSV書き出し"+Join(+Split(Join(Split(strNow,"/"),"-"),":"),"：")+".csv"
	PathExcel				="c:\temp\ACL CSV書き出し"+Join(+Split(Join(Split(strNow,"/"),"-"),":"),"：")+".xls"
	Open PathText For Output As fileNum%	
	
	
	
	wkinfo		=damidoc.txtACL(0)
	
	wkvari=Split(wkinfo,Chr(13)+Chr(10))
	Forall o1 In wkvari
		If Not((Trim(o1)="") Or (Instr(1,Cstr(Trim(o1)),"Lotus Notes Database")<>0) Or (Trim(o1)="Database Information")) Then
			i		=i+1
			
			'サーバー名
			If Not(Instr(1,Cstr(i/2),".")=0) Then
				wkserver=Trim(Join(Split(Join(Split(Cstr(o1),Chr(9)),""),"Server:"),""))				
				If wkserver="Local" Then
					wkserver=""
				End If
				
			'DBパス
			Else
				wkpath=Trim(Join(Split(Join(Split(Cstr(o1),Chr(9)),""),"Path:"),""))							
			End If
			
			If Instr(1,Cstr(i/2),".")=0 Then
				
			'DB取得
				Set Odb	=ss.GetDatabase(wkserver,wkpath)
				If Odb.IsOpen=True Then				
					
					Set acl = Odb.ACL
					
					allArray = acl.Roles
					
					
					'names.nsfの取得
					Set NamesDb=ss.GetDatabase(wkserver,"names.nsf")
					
					'グループビューの取得
					Set NamesView=NamesDb.GetView("グループ(_G)")
					
					
				'タイトル
					'Print #fileNum%,Odb.Title+"  ("+wkserver+")  ("+wkpath+")"
					Print #fileNum%,""
					Print #fileNum%,""
					Print #fileNum%,"エントリ名"+","+"種類"+","+"レベル"+","+"GpMember"+","+"文書作成"+","+"文書削除"+","+"複製Copy"+","+Join(allArray,",")
					
					
					Set aEntry = acl.GetFirstEntry
					Do While Not(aEntry Is Nothing)					
						
						
						Select Case aEntry.UserType
						Case 0
							wktype="未定義"
						Case 1
							wktype="Person"
						Case 2
							wktype="Server"
						Case 3
							wktype="MIXED_GROUP"
						Case 4
							wktype="Group"
						Case 5
							wktype="Server Group"
						Case Else
							wktype="？"
						End Select
						
						
						Select Case aEntry.Level
						Case 0
							wklevel="No Access"
						Case 1
							wklevel="投稿者"
						Case 2
							wklevel="読者"
						Case 3
							wklevel="作成者"
						Case 4
							wklevel="編集者"
						Case 5
							wklevel="設計者"
						Case 6
							wklevel="管理者"
						End Select
						
						
						If aEntry.CanCreateDocuments=True Then
							wkCanCD="○"
						Else
							wkCanCD="×"
						End If
						If aEntry.CanDeleteDocuments=True Then
							wkCanDelD="○"
						Else
							wkCanDelD="×"
						End If
						
						If aEntry.CanReplicateOrCopyDocuments=True Then
							wkCanRepC="○"	
						Else
							wkCanRepC="×"
						End If
						
					'+Join(aclArray,",")	
						
						roleinfo=""
						Forall o2 In allArray
							If Isnull(Arraygetindex(aEntry.Roles,Cstr(o2))) Then
								roleinfo			=roleinfo+"×"+","
							Else
								roleinfo			=roleinfo+"○"+","
							End If
						End Forall
						
						If roleinfo<>"" Then
							If Right(roleinfo,1)="," Then
								roleinfo			=Left(roleinfo,Len(roleinfo)-1)
							End If
						End If
						
						
						
						'グループ名のメンバーを検索する。
						
						Dim strGpMember As String
						Dim nam			As NotesName
						Dim strconv1		As String
						Dim strconv2		As String
						
						wkGpMember=""
						If aEntry.UserType=4 Then
							Set NamesDoc=NamesView.GetFirstDocument
							Do While Not(NamesDoc Is Nothing)								
								
								'2012.3.16  追加
								'小文字に変換して比較
								'-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.
								strconv1=Strconv (Cstr(NamesDoc.ListName(0)),2)
								strconv2=Strconv (Cstr(aEntry.Name),2)
								'-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.-.								
								
								If strconv1 = strconv2 Then
									strGpMember=""
									Forall o10 In NamesDoc.Members										
										Set nam 		= ss.CreateName(o10)	
										strGpMember	=strGpMember+nam.Abbreviated+"◆"
										Set nam		=Nothing
									End Forall
									
									If Right(strGpMember,1)="◆" Then
										strGpMember	=Left(strGpMember,Len(strGpMember)-1)
									End If
									
									wkGpMember=strGpMember
									Exit Do
								End If								
								Set NamesDoc=NamesView.GetNextDocument(NamesDoc)
								
							Loop
							'NamesDoc
							
						End If
						
						
						Print #fileNum%,aEntry.Name+","+wktype+","+wklevel+","+wkGpMember+","+wkCanCD+","+wkCanDelD+","+wkCanRepC+","+roleinfo
						
						Set aEntry = acl.GetNextEntry(aEntry)
					Loop
					
				End If
				
				Exit Forall
			End If		
		End If
	End Forall
	
	
	Close fileNum%	
	
	
	Dim XObj As Variant
	Dim XBook As Variant
	Dim XSheet As Variant
	
	Set XObj 					= CreateObject("Excel.Application")
	XObj.DisplayAlerts			= True
	XObj.Visible 				= True
	
	Set XBook				= XObj.Workbooks.add
	XBook.Saved			= True
	
	
		'Call XBook.SaveAs(Prodoc.AnalysisfileExcel(0),-4143)	
	Set XSheet 				= XObj.Workbooks(1).Worksheets(1)  	
	XSheet.Activate		
	XSheet.Range("A1").Select
	
	
	
		'/外部データの取込
	With  XSheet.QueryTables.Add("TEXT;"+PathText, XSheet.Range("A1"))
		.Name 						= ""
		.FieldNames 				= True
		.RowNumbers 				= False
		.FillAdjacentFormulas 	= False
		.PreserveFormatting 		= True
		.RefreshOnFileOpen 		= False
		.RefreshStyle 			= 1		
		.SavePassword			= False
		.SaveData					= True
		.AdjustColumnWidth		= True
		.RefreshPeriod			= 0
		.TextFilePromptOnRefresh	= False
		.TextFilePlatform			= 932
		.TextFileStartRow		= 1
		.TextFileParseType		= 1
		.TextFileTextQualifier	= -4142 
		.TextFileConsecutiveDelimiter	= False
		.TextFileTabDelimiter			= False
		.TextFileSemicolonDelimiter 	= False
		.TextFileCommaDelimiter 		= True
		.TextFileSpaceDelimiter 			= False
			'.TextFileColumnDataTypes 		= CellDataType
		.TextFileTrailingMinusNumbers 	= True
		.Refresh		
	End With
	
	
	
	
	
	XSheet.Range("A1").Select
	
	
	'GpMemberのセパレーション記号"◆"を、セル内改行に変換
	'strSamp = Replace(strSamp, "123", "000")
	Dim Gpi As Integer
	Dim SellValue As String
	Dim Ret As Variant
	Gpi=4
	
	Do While(True)
		If XSheet.Range("A"+Cstr(Gpi)).Value<>"" Then
			SellValue	=XSheet.Range("D"+Cstr(Gpi)).Value
			Ret			=Instr(1,SellValue,"◆")
			If Ret>0 Then
				'値置換
				XSheet.Range("D"+Cstr(Gpi)).Value=Join(Split(SellValue,"◆"),Chr(13)+Chr(10))				
			End If
		Else
			Exit Do
		End If
		Gpi=Gpi+1
	Loop
	
	
	
	
	'XSheet.Range(A1).
	XSheet.Cells(1, 1).Value = Odb.Title+"  ("+wkserver+")  ("+wkpath+")"
	
	
		'/保存
	
	XObj.ActiveWindow.Zoom = 75
	XSheet.Rows("4:4").Select
	XObj.ActiveWindow.FreezePanes = True
	
	XSheet.Range("A1").Select
	Call XObj.Workbooks(1).SaveAs(PathExcel,51,"")
	
	
	
%REM


	ActiveWindow.Zoom = 75
	Range("A1").Select
	Selection.ClearContents
	Columns("A:A").ColumnWidth = 53.5
	Range("E17").Select
    ActiveWindow.SmallScroll Down:=-6
	Rows("4:4").Select
	ActiveWindow.FreezePanes = True
	Range("A1").Select
    ActiveWindow.SmallScroll Down:=-6
%END REM	
	
		'/元リソースを削除
	Kill PathText
	
	
End Sub