VBAでicsファイルを作成し、LINEWORKSなどのカレンダーにインポートできるようにしたい。

前提・実現したいこと

Excelで入力した予定からicsファイルを生成し、
LINEWORKSなどのカレンダーにインポートできるようにしたい。

事情によりVBAでの作成を考えています。

発生している問題・エラーメッセージ

有効なファイルではありません。インポートするファイルの形式を確認してください。
iCalファイル(拡張子.ics)は、カレンダーデータを送信する際に使用される標準のカレンダー形式です。iCalファイルをインポートするためにはファイルが正しくフォーマットされている必要があります。

上記のエラーメッセージが表示され、インポートすることができない。

該当のソースコード

予定を入力すると、一番左の列にiCalに対応した形式で生成。
VBAにてヘッダー部分を記述したのち、A列の内容を1行ずつ読み込むプログラム。

VBA
1Sub import()
2    Dim ws As Worksheet
3    Set ws = ThisWorkbook.Worksheets(1)
4    
5    Dim sr As ADODB.Stream     
6    Set sr = New ADODB.Stream
7
8    With sr
9        .Charset = "UTF-8"
10        .Mode = adModeReadWrite
11        .Type = adTypeText
12        .LineSeparator = adCRLF
13        .Open
14        
15        .WriteText "BEGIN:VCALENDARPRODID:Works Mobile CalendarVERSION:2.0CALSCALE:GREGORIANMETHOD:PublishBEGIN:VTIMEZONE", adWriteLine
16        .WriteText "TZID:Asia/Tokyo", adWriteLine
17        .WriteText "TZURL:http://tzurl.org/zoneinfo-outlook/Asia/Tokyo", adWriteLine
18        .WriteText "X-LIC-LOCATION:Asia/Tokyo", adWriteLine
19        .WriteText "BEGIN:STANDARD", adWriteLine
20        .WriteText "TZOFFSETFROM:+0900", adWriteLine
21        .WriteText "TZOFFSETTO:+0900", adWriteLine
22        .WriteText "TZNAME:JST", adWriteLine
23        .WriteText "DTSTART:19700101T000000", adWriteLine
24        .WriteText "END:STANDARD", adWriteLine
25        .WriteText "END:VTIMEZONE", adWriteLine
26
27        Dim i As Long
28        i = 1
29        Do While ws.Cells(i, adWriteLine).Value <> ""
30            .WriteText ws.Cells(i, adWriteLine).Value, adWriteLine
31            i = i + 1
32        Loop
33    
34        .WriteText "END:VCALENDAR"
35        
36        ''''''BOM無し対応''''''
37        .Position = 0 'ストリームの位置を0にする
38        .Type = 1 'データの種類をバイナリデータに変更
39        .Position = 3 'ストリームの位置を3にする
40        
41        Dim byteData() As Byte '一時格納用
42        byteData = .Read 'ストリームの内容を一時格納用変数に保存
43        .Close '一旦ストリームを閉じる（リセット）
44        
45        .Open 'ストリームを開く
46        .Write byteData 'ストリームに一時格納したデータを流し込む
47        '''''''''''''''''''''''
48
49        .SaveToFile ActiveWorkbook.Path & "\import.ics", adSaveCreateOverWrite
50        .Close
51        
52    End With
53    
54    MsgBox "import.icsに書き出しました"
55    
56End Sub
57
58
59