Export Chinese Characters From Excel To ICS

Question

Macro stops as soon as there are Chinese characters like š访问父母 in Summary. Works fine using English. With Chinese it shows Run-Time error '5': Invalid procedure call or argument and when going into details the line below is highlighted. objFile.write "SUMMARY:" & Summary & vbCrLf Help in how to tackle this would be appreciated.

Sub Create_ICS()

Dim CSV_Name As String
CSV_Name = ThisWorkbook.Names("CSV_Name").RefersToRange + ".ics"
If CSV_Name = ".ics" Then GoTo No_Filename

Dim Folder_Existence As String
Folder_Existence = ThisWorkbook.Names("Folder_Existence").RefersToRange
If Folder_Existence <> "" Then GoTo No_Such_Folder

Sheets("ICS").Select

' PARAMETERS
Dim Last_Columm As Long
Last_Columm = 21
Dim First_Row As Long
First_Row = 2

Dim ICS_Format As String
ICS_Format = ThisWorkbook.Names("ICS_Format").RefersToRange

Dim Time_Zone_Selected As String
Time_Zone_Selected = ThisWorkbook.Names("Time_Zone_Selected").RefersToRange

Dim Calendar_ID As String
Calendar_ID = ThisWorkbook.Names("Calendar_ID").RefersToRange

Dim CSV_Directory As String
CSV_Directory = ThisWorkbook.Names("CSV_Directory").RefersToRange

Dim Sync_URL As String
Sync_URL = ThisWorkbook.Names("Sync_URL").RefersToRange + CSV_Name

Dim Time_Format As String
Time_Format = ThisWorkbook.Names("Time_Format").RefersToRange
If Time_Format = "Excel Timestamps" Then Application.Run "Excel_Timestamps"

Dim Total_Errors As Long
Application.Calculate
Total_Errors = ThisWorkbook.Names("Total_Errors").RefersToRange
If Total_Errors > 0 Then GoTo Fix_Errors

Start_Export:

Dim CSV_Slash As String
CSV_Slash = Right(CSV_Directory, 1)
Dim Slash As String
If CSV_Slash = "\" Then Slash = ""
If CSV_Slash <> "\" Then Slash = "\"

Dim CSV_Filename As String
CSV_Filename = CSV_Directory + Slash + CSV_Name


Dim rng1 As Range, X, i As Long, v As Long
Dim objFSO, objFile
Dim FilePath As String
FilePath = "D:\test.ics"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.CreateTextFile(CSV_Filename)

' SET AREA
Set rng1 = Range(Cells(First_Row, 1), Cells(Cells(Rows.Count, "A").End(xlUp).Row, Last_Columm))
X = rng1

'GoTo Details

' CREATE HEADER
objFile.write "BEGIN:VCALENDAR" & vbCrLf
objFile.write "CALSCALE:GREGORIAN" & vbCrLf
objFile.write "VERSION:2.0" & vbCrLf
objFile.write "METHOD:Publish" & vbCrLf
objFile.write "PRODID:-//None" & vbCrLf

Details:
Dim Summary As String
Dim Description As String
Dim DateStart As String
Dim TimeStart As String
Dim DateEnd As String
Dim TimeEnd As String
Dim Location As String
Dim Frequency As String
Dim Interval As String
Dim When As String
Dim ByDay As String
Dim ByMonthDay As String
Dim ByYearDay As String
Dim ByWeekNo As String
Dim ByMonth As String
Dim BySetPos As String
Dim WkSt As String
Dim Color As String
Dim Alarm As String
Dim TzId As String
Dim UID As String

' Create Details

For i = 1 To UBound(X, 1)

Summary = X(i, 1)
Description = X(i, 2)
DateStart = X(i, 3)
TimeStart = X(i, 4)
DateEnd = X(i, 5)
TimeEnd = X(i, 6)
Location = X(i, 7)
Frequency = X(i, 8)
Interval = X(i, 9)
When = X(i, 10)
ByDay = X(i, 11)
ByMonthDay = X(i, 12)
ByYearDay = X(i, 13)
ByWeekNo = X(i, 14)
ByMonth = X(i, 15)
BySetPos = X(i, 16)
WkSt = X(i, 17)
Color = X(i, 18)
Alarm = X(i, 19)
TzId = X(i, 20)
UID = X(i, 21)

'11
ByMonthDay = Right(DateStart, 2) / 1

If BySetPos = "L" Then BySetPos = "-1"

'14
ByMonth = Mid(DateStart, 5, 2) / 1

objFile.write "BEGIN:VEVENT" & vbCrLf

objFile.write "UID:" & UID & vbCrLf

objFile.write "DTSTAMP" & TzId & ":" & DateStart & "T000000" & ICS_Format & vbCrLf

If Description <> "" Then
    objFile.write "DESCRIPTION:" & Description & vbCrLf
End If

If TimeStart = "" Or TimeStart = "0" And TimeEnd = "0" Then
objFile.write "DTEND;VALUE=DATE:" & DateEnd & vbCrLf
Else
If Len(TimeEnd) = 3 Then TimeEnd = "000" + TimeEnd
If Len(TimeEnd) = 4 Then TimeEnd = "00" + TimeEnd
If Len(TimeEnd) = 5 Then TimeEnd = "0" + TimeEnd
objFile.write "DTEND" & TzId & ":" & DateEnd & "T" & TimeEnd & vbCrLf
End If

If Location <> "" Then
objFile.write "LOCATION:" & Location & vbCrLf
End If

objFile.write "SUMMARY:" & Summary & vbCrLf

If TimeStart = "" Or TimeStart = "0" And TimeEnd = "0" Then
objFile.write "DTSTART;VALUE=DATE:" & DateStart & vbCrLf ' All Day
Else
If Len(TimeStart) = 3 Then TimeStart = "000" + TimeStart
If Len(TimeStart) = 4 Then TimeStart = "00" + TimeStart
If Len(TimeStart) = 5 Then TimeStart = "0" + TimeStart
   objFile.write "DTSTART" & TzId & ":" & DateStart & "T" & TimeStart & vbCrLf
End If

If TimeStart = "" Or TimeStart = "0" And TimeEnd = "0" Then
   objFile.write "X-MICROSOFT-CDO-ALLDAYEVENT:TRUE" & vbCrLf
   objFile.write "X-FUNAMBOL-ALLDAY:1" & vbCrLf
End If

If Frequency <> "" And Interval = "" Then Interval = "1"

If Frequency = "DAILY" Then
   objFile.write "RRULE:FREQ=DAILY" & vbCrLf
ElseIf Frequency = "WEEKLY" Then
   objFile.write "RRULE:FREQ=" & Frequency & ";INTERVAL=" & Interval & vbCrLf

' Day X of each Y months
ElseIf Frequency = "MONTHLY" And ByDay = "" Then
    objFile.write "RRULE:FREQ=MONTHLY;INTERVAL=" & Interval & "BYMONTHDAY=" & ByMonthDay & vbCrLf

' Xth WeekDay of each Y months
ElseIf Frequency = "MONTHLY" And ByDay <> "" Then
    objFile.write "RRULE:FREQ=MONTHLY;INTERVAL=" & 1 & ";BYDAY=" & When & ByDay & vbCrLf

ElseIf Frequency = "YEARLY" And ByYearDay <> "" Then
    objFile.write "RRULE:FREQ=YEARLY;INTERVAL=" & Interval & ";BYYEARDAY=" & ByYearDay & vbCrLf

ElseIf Frequency = "YEARLY" And ByYearDay = "" Then
    objFile.write "RRULE:FREQ=YEARLY;INTERVAL=" & Interval & ";BYMONTHDAY=" & ByMonthDay & ";BYMONTH=" & ByMonth & vbCrLf
End If

If Alarm <> "" Then
Dim TRIGGER As String
If Alarm = "0" Then TRIGGER = "+PT0S"
If Alarm = "1440" Then TRIGGER = "-P1DT0S"
If Alarm / 1 > 0 And Alarm / 1 < 60 Then TRIGGER = "-PT0H" & Alarm & "M0S"
If Alarm / 1 > 59 And Alarm / 1 < 1440 Then TRIGGER = "-PT" & Int(Alarm / 60) & "H" & (Alarm / 60 - Int(Alarm / 60)) * 60 & "M0S"

objFile.write "DESCRIPTION:Event Reminder" & vbCrLf
objFile.write "ACTION: DISPLAY" & vbCrLf
objFile.write "End:VALARM" & vbCrLf
End If

If Color <> "" Then
   objFile.write "X-UTILITAP-COLOR: " & Color & vbCrLf
End If

objFile.write "END:VEVENT" & vbCrLf

Skip_Record:
Next i

' Create Footer
objFile.write "END:VCALENDAR"

Sheets("Instructions").Select
MsgBox "File " + CSV_Directory + CSV_Name + " created..."


GoTo Finish

Close_CSV:
MsgBox " The destination file " + CSV_Name + " is open, please close it first..."
GoTo Finish

No_Such_Folder:
MsgBox "Folder '" + CSV_Directory + "' doesn't exist, please fix this first...."
Application.GoTo Reference:="CSV_Directory"
GoTo Finish

No_Filename:
MsgBox "No file name specified, please fix this first...."
Application.GoTo Reference:="CSV_Name"
GoTo Finish

No_ICS_Rows:
MsgBox "Sheet 'ICS' doesn't contain calendar items, nothing to export...."
GoTo Finish

Fix_Errors:
MsgBox "Sheet 'ICS' contains errors, please fix these first...."
Application.Run "Filter_Errors"

GoTo Finish

No_Error_Checks:
    MsgBox "Sheet ICS doesn't contain error checks, this will be fixed now...."
Application.Run "Calendar_Checks"
Application.Calculate
GoTo Finish

Finish:

End Sub

Answer 1

The error is here:

 Set objFile = objFSO.CreateTextFile(CSV_Filename)

By default that's created as Ascii not UniCode. Replace with

 Set objFile = objFSO.CreateTextFile(filename:=CSV_Filename, Unicode:=true)