Option Explicit
Dim Key 
Dim Key2Index 
Call InitializeKey()
Call Main()
Sub InitializeKey()
	Key = Array( _
	"Name", _
	"Given Name", _
	"Family Name", _
	"Yomi Name", _
	"Family Name Yomi", _
	"Group Membership", _
	"Phone 1 - Type", _
	"Phone 1 - Value", _
	"Phone 2 - Type", _
	"Phone 2 - Value", _
	"Phone 3 - Type", _
	"Phone 3 - Value", _
	"E-mail 1 - Type", _
	"E-mail 1 - Value", _
	"E-mail 2 - Type", _
	"E-mail 2 - Value", _
	"E-mail 3 - Type", _
	"E-mail 3 - Value", _
	"Address 1 - Formatted", _
	"Address 2 - Formatted", _
	"Address 3 - Formatted", _
	"Birthday", _
	"Notes")
	Set Key2Index = CreateObject("Scripting.Dictionary")
	Dim i
	For i = 0 To UBound(Key)
		Key2Index.Add Key(i), i
	Next
End Sub
Sub Main()
Dim i : i = 0
Dim j : j = 0
Dim fso : Set fso = CreateObject("Scripting.FileSystemObject")
Dim strFilePath : strFilePath = GetArg()
Dim strFileName : strFileName = fso.GetFileName(strFilePath)
Dim strLines() : ReDim strLines(99999)
If IsEmpty(strFilePath) Then
	Exit Sub 
Else
	Call ReadLine(strLines, strFilePath)
End If
Dim CSVRows() : ReDim CSVRows(999)
Dim nRow : nRow  = 0
Do While i <= UBound(strLines)
	If strLines(i) = "BEGIN:VCARD" Then
		Dim Row 
		ReDim Row(UBound(Key))
		For j = 0 To UBound(Row)
			Row(j) = ""
		Next
		Dim nPhone : nPhone = 0 
		Dim nEMail : nEMail = 0 
		Dim nAddress : nAddress = 0 
		Dim nVCardLines : nVCardLines = 0 
		Do While True
			Dim BC : BC = Split(strLines(i),":")(0) 
			Dim AC : AC = Split(strLines(i),":")(1) 
			Dim BCSS : BCSS = Split(BC,";") 
			Dim strType : strType = ""
			If AC = "" Then
			Else		
				Select Case BCSS(0)
				Case "FN" 
				Case "N" 
					Dim strName : strName = Replace(AC, ";", "")
					Call AddInfo("Name", strName, Row)
					Call AddInfo("Given Name", strName, Row)
					Call AddInfo("Family Name", strName, Row)
				Case "SOUND" 
					Dim strYomi : strYomi = Replace(AC, ";", "")
					Call AddInfo("Yomi Name", strYomi, Row)
					Call AddInfo("Family Name Yomi", strYomi, Row)
				Case "EMAIL" 
					If nEMail < 3 Then
						nEMail = nEMail + 1 
						If InStr(1, BC, ";") > 0 Then
							strType = Split(BC, ";")(UBound(Split(BC,";")))
							If InStr(1, strType, "=") > 0 Then
								strType = Mid(strType, InStr(1, strType, "=") + 1)
							End If
							Select Case strType
							Case "INTERNET" : strType = "Home"
							Case "CELL"     : strType = "Other"
							Case "WORK"     : strType = "Work"
							End Select
						Else
							strType = ""
						End If
						Call AddInfo("E-mail " & nEMail & " - Type", strType, Row)
						Call AddInfo("E-mail " & nEMail & " - Value", AC, Row)
					End If
				Case "TEL" 
					If nPhone < 3 Then
						nPhone = nPhone + 1
						If UBOUND(BCSS) > 0 Then
							Select Case BCSS(1)
							Case "CELL" 
								strType = "Mobile"
							Case "VOICE" 
								strType = "Home"
							Case "WORK" 
								strType = "Work"
							End Select
							Call AddInfo("Phone " & nPhone & " - Type", strType, Row)
						End If
						Call AddInfo("Phone " & nPhone & " - Value", AC, Row) 
					End If
				Case "X-GN" 
					Call AddInfo("Group Membership", AC, Row)
				Case "ADR" 
					If nAddress < 3 Then
						nAddress = nAddress + 1
						Dim strAdr : strAdr = Split(AC, ";")(1) 
						Dim strZip : strZip = Split(AC, ";")(5) 
						If (strZip = "") Or (Len(strZip) <> 7) Then
							Call AddInfo("Address " & nAddress & " - Formatted", strAdr, Row)
						Else
							strZip = Mid(strZip, 1, 3) + "-" + Mid(strZip, 4)
							Call AddInfo("Address " & nAddress & " - Formatted", strZip & " " & strAdr, Row)
						End If
					End If
				Case "BDAY"	
					Dim strBirthday
					If Len(AC) = 8 Then 
						strBirthday = Mid(AC, 1, 4) & "-" & Mid(AC, 5, 2) & "-" & Mid(AC, 7, 2)
					ElseIf Len(AC) = 10 Then 
						strBirthday = AC
					Else
						strBirthday = AC
					End If
					Call AddInfo("Birthday", strBirthday, Row)
				Case "NOTE" 
					Call AddInfo("Notes", AC, Row)
				Case "END" 
					Exit Do
				End Select
			End If
			i = i + 1
			nVCardLines = nVCardLines + 1
		Loop
		CSVRows(nRow) = Row
		nRow = nRow + 1
	End If
	i = i + 1
Loop
ReDim Preserve CSVRows(nRow - 1)
Dim strOutput() : ReDim strOutput(1 + UBound(CSVRows))
For i = 0 To UBound(strOutput)
	strOutput(i) = ""
Next
For i = 0 To UBound(Key)
	strOutput(0) = strOutput(0) & Key(i) & ","
Next
For i = 1 To UBound(strOutput)
	For j = 0 To UBound(Key)
		Dim strValue : strValue = CSVRows(i - 1)(j)
		If InStr(1, strValue, """") Then
			strValue = Replace(strValue, """", """""") ' 「"」を「""」に
			strValue = """" & strValue & """"
		End If
		strOutput(i) = strOutput(i) & strValue & ","
	Next
Next
Call InputTextFile(strOutput, strFileName & ".csv")
End Sub 
Sub AddInfo(ByVal strKey, ByVal strValue, ByRef strRow())
	strRow(Key2Index.Item(strKey)) = strValue
End Sub
Sub ReadLine(ByRef strLineArray(), ByVal strFilePath)
Const ForReading = 1	
Dim objFileSys : Set objFileSys = CreateObject("Scripting.FileSystemObject")
Dim objInFile : Set objInFile = objFileSys.OpenTextFile(strFilePath, ForReading)
Dim i : i = 0
If Err.Number=0 Then
	Do Until objInFile.AtEndOfStream = True
		strLineArray(i) = objInFile.ReadLine
		i = i + 1
	Loop
	objInFile.Close
	ReDim Preserve strLineArray(i)
Else
	ReDim Preserve strLineArray(0)
End If
Set objFileSys = Nothing
Set objInFile = Nothing
End Sub
Function GetArg()
Dim objArg : Set objArg = Wscript.Arguments
If objArg.Count = 0 Then
	WScript.echo "対象ファイルをドラッグアンドドロップしてください。"
	GetArg = Empty
ElseIf objArg.Count > 1 Then
	WScript.echo "対象とできるファイルは１つのみです。"
	GetArg = Empty
Else
	GetArg = objArg(0)
End If
End Function
Function InputTextFile(ByVal strLineArray, ByVal strNewFileName)
Const ForAppending = 8	
Dim objFileSys : Set objFileSys = CreateObject("Scripting.FileSystemObject")
Dim strScriptPath : strScriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
Dim strCreateFile : strCreateFile = objFileSys.BuildPath(strScriptPath, strNewFileName)
objFileSys.CreateTextFile strCreateFile
Dim objNewFile : Set objNewFile = objFileSys.OpenTextFile(strCreateFile, ForAppending)
Dim counter
For counter = 0 To UBound(strLineArray)
	objNewFile.WriteLine strLineArray(counter)
Next
objNewFile.Close
Set objFileSys = Nothing
Set objNewFile = Nothing
End Function