331 lines
10 KiB
QBasic
331 lines
10 KiB
QBasic
Attribute VB_Name = "ExportICS"
|
||
Option Explicit
|
||
|
||
'=====================================================================
|
||
' 予定一覧テーブルからICSを作成し保存する
|
||
'=====================================================================
|
||
Public Sub ExportScheduleTableToICS()
|
||
On Error Goto ErrHandler
|
||
|
||
Dim lo As ListObject
|
||
Set lo = FindListObjectByName("予定一覧")
|
||
If lo Is Nothing Then
|
||
Set lo = FindListObjectByName("登録予定一覧")
|
||
End If
|
||
If lo Is Nothing Then
|
||
MsgBox "テーブル「予定一覧」が見つかりません。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
If lo.DataBodyRange Is Nothing Then
|
||
MsgBox "テーブル「予定一覧」にデータがありません。", vbInformation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim idxStartDate As Long
|
||
Dim idxStartTime As Long
|
||
Dim idxEndDate As Long
|
||
Dim idxEndTime As Long
|
||
Dim idxAllDay As Long
|
||
Dim idxTitle As Long
|
||
Dim idxDesc As Long
|
||
Dim idxCheck As Long
|
||
Dim idxOutput As Long
|
||
|
||
idxStartDate = GetListColumnIndex(lo, "開始日")
|
||
idxStartTime = GetListColumnIndex(lo, "開始時刻")
|
||
idxEndDate = GetListColumnIndex(lo, "終了日")
|
||
idxEndTime = GetListColumnIndex(lo, "終了時刻")
|
||
idxAllDay = GetListColumnIndex(lo, "終日")
|
||
idxTitle = GetListColumnIndex(lo, "件名")
|
||
idxDesc = GetListColumnIndex(lo, "内容")
|
||
idxCheck = GetListColumnIndex(lo, "check")
|
||
idxOutput = GetListColumnIndex(lo, "出力")
|
||
|
||
If idxStartDate = 0 Or idxStartTime = 0 Or idxEndDate = 0 Or idxEndTime = 0 Or _
|
||
idxAllDay = 0 Or idxTitle = 0 Or idxDesc = 0 Or idxCheck = 0 Or idxOutput = 0 Then
|
||
MsgBox "必要な列が不足しています。列名を確認してください。", vbExclamation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim icsBody As String
|
||
Dim rowItem As ListRow
|
||
Dim exportedCount As Long
|
||
exportedCount = 0
|
||
|
||
For Each rowItem In lo.ListRows
|
||
Dim checkValue As String
|
||
Dim outputValue As String
|
||
checkValue = CStr(rowItem.Range.Cells(1, idxCheck).Value)
|
||
outputValue = CStr(rowItem.Range.Cells(1, idxOutput).Value)
|
||
|
||
If IsCheckOk(checkValue) And IsOutputBlank(outputValue) Then
|
||
Dim ev As String
|
||
ev = BuildEventBlock(rowItem, idxStartDate, idxStartTime, idxEndDate, idxEndTime, idxAllDay, idxTitle, idxDesc)
|
||
|
||
If ev <> "" Then
|
||
icsBody = icsBody & ev
|
||
rowItem.Range.Cells(1, idxOutput).Value = "済"
|
||
exportedCount = exportedCount + 1
|
||
End If
|
||
End If
|
||
Next rowItem
|
||
|
||
If exportedCount = 0 Then
|
||
MsgBox "出力対象（check=OK かつ 出力が空欄）のデータがありません。", vbInformation
|
||
Exit Sub
|
||
End If
|
||
|
||
Dim icsText As String
|
||
icsText = BuildCalendarText(icsBody)
|
||
|
||
Dim fileName As String
|
||
fileName = "予定一括登録_" & Format$(Now, "yyyymmdd_hhnnss") & ".ics"
|
||
|
||
Dim savePath As String
|
||
savePath = ThisWorkbook.Path & Application.PathSeparator & fileName
|
||
|
||
WriteTextUtf8 savePath, icsText
|
||
|
||
MsgBox "ICSファイルを出力しました。" & vbCrLf & _
|
||
"ファイル: " & fileName & vbCrLf & _
|
||
"件数: " & CStr(exportedCount) & "件", vbInformation
|
||
Exit Sub
|
||
|
||
ErrHandler:
|
||
MsgBox "ICS出力中にエラーが発生しました。" & vbCrLf & _
|
||
"番号: " & Err.Number & vbCrLf & _
|
||
"内容: " & Err.Description, vbCritical
|
||
End Sub
|
||
|
||
Private Function BuildCalendarText(Byval eventBlocks As String) As String
|
||
Dim txt As String
|
||
txt = "BEGIN:VCALENDAR" & vbCrLf & _
|
||
"PRODID:-//MyLINEWORKS_CAL_IMPORT//JP" & vbCrLf & _
|
||
"VERSION:2.0" & vbCrLf & _
|
||
"CALSCALE:GREGORIAN" & vbCrLf & _
|
||
"METHOD:PUBLISH" & vbCrLf & _
|
||
vbCrLf & _
|
||
eventBlocks & _
|
||
"END:VCALENDAR" & vbCrLf
|
||
BuildCalendarText = txt
|
||
End Function
|
||
|
||
Private Function BuildEventBlock( _
|
||
Byval rowItem As ListRow, _
|
||
Byval idxStartDate As Long, _
|
||
Byval idxStartTime As Long, _
|
||
Byval idxEndDate As Long, _
|
||
Byval idxEndTime As Long, _
|
||
Byval idxAllDay As Long, _
|
||
Byval idxTitle As Long, _
|
||
Byval idxDesc As Long) As String
|
||
|
||
On Error Goto BuildErr
|
||
|
||
Dim startDateValue As Variant
|
||
Dim startTimeValue As Variant
|
||
Dim endDateValue As Variant
|
||
Dim endTimeValue As Variant
|
||
Dim allDayValue As Variant
|
||
|
||
startDateValue = rowItem.Range.Cells(1, idxStartDate).Value
|
||
startTimeValue = rowItem.Range.Cells(1, idxStartTime).Value
|
||
endDateValue = rowItem.Range.Cells(1, idxEndDate).Value
|
||
endTimeValue = rowItem.Range.Cells(1, idxEndTime).Value
|
||
allDayValue = rowItem.Range.Cells(1, idxAllDay).Value
|
||
|
||
If Not IsDate(startDateValue) Or Not IsDate(endDateValue) Then
|
||
BuildEventBlock = ""
|
||
Exit Function
|
||
End If
|
||
|
||
Dim startDate As Date
|
||
Dim endDate As Date
|
||
startDate = DateValue(CDate(startDateValue))
|
||
endDate = DateValue(CDate(endDateValue))
|
||
|
||
Dim isAllDay As Boolean
|
||
isAllDay = (Val(CStr(allDayValue)) = 1)
|
||
|
||
Dim lines As String
|
||
lines = "BEGIN:VEVENT" & vbCrLf
|
||
|
||
If isAllDay Then
|
||
lines = lines & "DTSTART;VALUE=DATE:" & Format$(startDate, "yyyymmdd") & vbCrLf
|
||
lines = lines & "DTEND;VALUE=DATE:" & Format$(DateAdd("d", 1, endDate), "yyyymmdd") & vbCrLf
|
||
Else
|
||
If Not CanParseTime(startTimeValue) Or Not CanParseTime(endTimeValue) Then
|
||
BuildEventBlock = ""
|
||
Exit Function
|
||
End If
|
||
|
||
Dim localStart As Date
|
||
Dim localEnd As Date
|
||
localStart = DateValue(startDate) + TimeValue(CDate(startTimeValue))
|
||
localEnd = DateValue(endDate) + TimeValue(CDate(endTimeValue))
|
||
|
||
Dim utcStart As Date
|
||
Dim utcEnd As Date
|
||
utcStart = LocalToUtc(localStart)
|
||
utcEnd = LocalToUtc(localEnd)
|
||
|
||
lines = lines & "DTSTART:" & Format$(utcStart, "yyyymmdd") & "T" & Format$(utcStart, "hhnnss") & "Z" & vbCrLf
|
||
lines = lines & "DTEND:" & Format$(utcEnd, "yyyymmdd") & "T" & Format$(utcEnd, "hhnnss") & "Z" & vbCrLf
|
||
End If
|
||
|
||
Dim titleText As String
|
||
titleText = Trim$(CStr(rowItem.Range.Cells(1, idxTitle).Value))
|
||
If titleText <> "" Then
|
||
lines = lines & "SUMMARY:" & EscapeIcsText(titleText) & vbCrLf
|
||
End If
|
||
|
||
Dim descText As String
|
||
descText = CStr(rowItem.Range.Cells(1, idxDesc).Value)
|
||
If Trim$(descText) <> "" Then
|
||
lines = lines & "DESCRIPTION:" & EscapeIcsDescriptionText(descText) & vbCrLf
|
||
End If
|
||
|
||
lines = lines & "END:VEVENT" & vbCrLf
|
||
|
||
BuildEventBlock = lines
|
||
Exit Function
|
||
|
||
BuildErr:
|
||
BuildEventBlock = ""
|
||
End Function
|
||
|
||
Private Function EscapeIcsText(Byval txt As String) As String
|
||
Dim s As String
|
||
s = txt
|
||
s = Replace(s, "\", "\\")
|
||
s = Replace(s, ";", "\;")
|
||
s = Replace(s, ",", "\,")
|
||
EscapeIcsText = s
|
||
End Function
|
||
|
||
Private Function EscapeIcsDescriptionText(Byval txt As String) As String
|
||
Const NL_TOKEN As String = "__ICS_NEWLINE_TOKEN__"
|
||
|
||
Dim s As String
|
||
s = NormalizeLineBreak(txt)
|
||
s = Replace(s, vbCrLf, NL_TOKEN)
|
||
s = Replace(s, vbLf, NL_TOKEN)
|
||
s = Replace(s, vbCr, NL_TOKEN)
|
||
|
||
s = EscapeIcsText(s)
|
||
s = Replace(s, NL_TOKEN, "\n")
|
||
|
||
EscapeIcsDescriptionText = s
|
||
End Function
|
||
|
||
Private Function NormalizeLineBreak(Byval txt As String) As String
|
||
Dim s As String
|
||
s = Replace(txt, vbCrLf, vbLf)
|
||
s = Replace(s, vbCr, vbLf)
|
||
NormalizeLineBreak = Replace(s, vbLf, vbCrLf)
|
||
End Function
|
||
|
||
Private Function IsCheckOk(Byval rawValue As String) As Boolean
|
||
Dim s As String
|
||
s = NormalizeText(rawValue)
|
||
IsCheckOk = (s = "OK")
|
||
End Function
|
||
|
||
Private Function IsOutputBlank(Byval rawValue As String) As Boolean
|
||
Dim s As String
|
||
s = NormalizeText(rawValue)
|
||
IsOutputBlank = (s = "")
|
||
End Function
|
||
|
||
Private Function NormalizeText(Byval txt As String) As String
|
||
Dim s As String
|
||
s = txt
|
||
s = Replace(s, Chr$(160), " ")
|
||
s = Replace(s, ChrW$(12288), " ")
|
||
s = Replace(s, vbTab, " ")
|
||
s = Trim$(s)
|
||
On Error Resume Next
|
||
s = StrConv(s, vbNarrow)
|
||
On Error Goto 0
|
||
NormalizeText = UCase$(s)
|
||
End Function
|
||
|
||
Private Function CanParseTime(Byval v As Variant) As Boolean
|
||
On Error Goto ParseErr
|
||
Dim t As Date
|
||
t = TimeValue(CDate(v))
|
||
CanParseTime = True
|
||
Exit Function
|
||
|
||
ParseErr:
|
||
CanParseTime = False
|
||
End Function
|
||
|
||
Private Function FindListObjectByName(Byval tableName As String) As ListObject
|
||
Dim ws As Worksheet
|
||
Dim lo As ListObject
|
||
|
||
For Each ws In ThisWorkbook.Worksheets
|
||
For Each lo In ws.ListObjects
|
||
If StrComp(lo.Name, tableName, vbTextCompare) = 0 Then
|
||
Set FindListObjectByName = lo
|
||
Exit Function
|
||
End If
|
||
Next lo
|
||
Next ws
|
||
End Function
|
||
|
||
Private Function GetListColumnIndex(Byval lo As ListObject, Byval colName As String) As Long
|
||
On Error Goto ColErr
|
||
GetListColumnIndex = lo.ListColumns(colName).Index
|
||
Exit Function
|
||
|
||
ColErr:
|
||
GetListColumnIndex = 0
|
||
End Function
|
||
|
||
Private Sub WriteTextUtf8(Byval filePath As String, Byval textContent As String)
|
||
Dim stm As Object
|
||
Set stm = CreateObject("ADODB.Stream")
|
||
|
||
With stm
|
||
.Type = 2
|
||
.Charset = "utf-8"
|
||
.Open
|
||
.WriteText textContent
|
||
.Position = 0
|
||
.SaveToFile filePath, 2
|
||
.Close
|
||
End With
|
||
|
||
Set stm = Nothing
|
||
End Sub
|
||
|
||
Private Function LocalToUtc(Byval localDateTime As Date) As Date
|
||
Dim utcBiasMinutes As Long
|
||
utcBiasMinutes = GetCurrentUtcBiasMinutes()
|
||
LocalToUtc = DateAdd("n", -utcBiasMinutes, localDateTime)
|
||
End Function
|
||
|
||
Private Function GetCurrentUtcBiasMinutes() As Long
|
||
'Win32_TimeZone.Biasは「UTC = Local + Bias(分)」の定義
|
||
On Error Goto Fallback
|
||
|
||
Dim wmi As Object
|
||
Dim tzSet As Object
|
||
Dim tz As Object
|
||
|
||
Set wmi = GetObject("winmgmts:\\.\root\cimv2")
|
||
Set tzSet = wmi.ExecQuery("Select Bias FROM Win32_TimeZone")
|
||
|
||
For Each tz In tzSet
|
||
GetCurrentUtcBiasMinutes = CLng(tz.Bias)
|
||
Exit Function
|
||
Next tz
|
||
|
||
Fallback:
|
||
'取得できない場合はJST(UTC+9)相当を既定値とする
|
||
GetCurrentUtcBiasMinutes = -540
|
||
End Function
|