1
概要でš访问父母のような漢字があるとすぐにマクロが停止します。 英語でうまく動作します。 中国語ではランタイムエラー '5'が表示されます：プロシージャコールまたは引数が無効です。詳細に進むと、下の行が強調表示されます。 objFile.write "要約：" &要約& vbCrLf これに取り組む方法のヘルプは高く評価されます。ExcelからICSに中国語の文字をエクスポートする
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