2012年03月31日

ジョルテ(JORTE)とoutlookの同期

Android スマホ の予定表ソフトでいいのがないか探していたら、「ジョルテ (JORTE)」という、超便利でカッコイイソフトを見つけた。
outlook 予定表とジョルテを同期したいが、Googleカレンダーは怖いので使いたくない、と思って色々さがしたが、良い方法がない。

ジョルテは、CSV形式でインポート/エクスポートできるみたいなので、
(1) outlook 予定表からCSV形式でエクスポート
(2) スマホを USB 接続して (1) をコピー
(3) ジョルテで (2) をインポート
できないか探してみたら、(1) の CSV形式でエクスポートする VBAマクロ が公開されてたのでそれを参考にグジグジ修正。
VBA は Shift_JIS or UTF-16 で file save してしまうのだが、Android は UTF-8 でなければならない。このミスマッチを埋めるために
(1) ADODB.Stream オブジェクトを使い、
(2) 一旦 text mode で書き込み、
(3) binary mode で read/re-write.
という手を使った。

折角だから公開↓


'################################################################
'outlook to JORTE(android), CSV output macro
'################################################################

Public Sub ExportMyCaldndar()
Const MY_CSV_FILE_NAME = "schedule_data.csv" '## JORTEのデフォルトファイル名
Dim fldCalendar ' As Folder
Set fldCalendar = Application.Session.GetDefaultFolder(olFolderCalendar)
ExportThisMonth fldCalendar, MY_CSV_FILE_NAME
End Sub

' 共通ルーチン
Public Sub ExportThisMonth(fldCalendar, strCsvName As String)
'#### const section
Const JORTE_ENV = "JORTEDIR" '#### 環境変数 %JORTEDIR% 配下に書き込む

'#### Dim section
Dim strFileName As String
Dim strStart As String
Dim strEnd As String
Dim dtExport As Date
Dim objFSO 'As FileSystemObject
Dim stmCSVFile 'As TextStream
Dim colAppts As Items
Dim objAppt 'As AppointmentItem
Dim strLine As String
Dim envString As String '環境変数
Dim FSO As Object 'フォルダの存在有無
'
'#### 出力ファイル名の設定
'# 1) 環境変数 JORTEDIR があり && 書き込み可能
'# 2) なければ、環境変数 TEMP があり && 書き込み可能
'# 3) それもなければ、C:\ に書き込む
envString = Environ(JORTE_ENV)
Set FSO = CreateObject("Scripting.FileSystemObject")
On Error GoTo EnvErr1
If envString = "" Or Not FSO.FolderExists(envString) Then
On Error GoTo EnvErr2
envString = Environ("TEMP")
If envString = "" Or Not FSO.FolderExists(envString) Then
On Error GoTo 0
envString = "c:"
End If
End If
GoTo EnvBrk
EnvErr1:
Resume Next
EnvErr2:
Resume Next
EnvBrk:
strFileName = envString & "\" & strCsvName


dtExport = Now
strStart = Year(Now) & "/" & Month(Now) & "/1 00:00"
'strEnd = DateAdd("m", 1, CDate(strStart)) & " 00:00"
strEnd = DateAdd("m", 2, CDate(strStart)) & " 00:00"
'
'Set objFSO = CreateObject("Scripting.FileSystemObject")
'Set stmCSVFile = objFSO.CreateTextFile(strFileName, True)

' ADODB.Streamのモード
Dim adTypeBinary: adTypeBinary = 1
Dim adTypeText: adTypeText = 2
Dim adSaveCreateOverWrite: adSaveCreateOverWrite = 2

' ADODB.Streamを作成
Dim pre: Set pre = CreateObject("ADODB.Stream")
' 最初はテキストモードでUTF-8で書き込む
pre.Type = adTypeText
pre.Charset = "UTF-8"
pre.Open

' CSV ファイルのヘッダです。出力するフィールドを増減する場合はこちらも変更してください。
' stmCSVFile.WriteLine """件名"",""場所"",""開始日"",""開始時刻"",""終了日"",""終了時刻"",""分類項目"",""主催者"",""必須出席者"",""任意出席者"""
pre.WriteText ("dtstart,dtend,time_start,time_end,title,timeslot,holiday,event_timezone,calendar_rule,rrule,on_holiday_rule,content,location,importance,completion,char_color,icon_id,reminders" & vbCrLf)
'

Set colAppts = fldCalendar.Items
colAppts.Sort "[Start]"
colAppts.IncludeRecurrences = True
Set objAppt = colAppts.Find("[Start] < """ & strEnd & """ AND [End] >= """ & strStart & """")
While Not objAppt Is Nothing
' strLine = """" & objAppt.Subject & _
' """,""" & objAppt.Location & _
' """,""" & FormatDateTime(objAppt.Start, vbShortDate) & _
' """,""" & FormatDateTime(objAppt.Start, vbShortTime) & _
' """,""" & FormatDateTime(objAppt.End, vbShortDate) & _
' """,""" & FormatDateTime(objAppt.End, vbShortTime) & _
' """,""" & objAppt.Categories & _
' """,""" & objAppt.Organizer & _
' """,""" & objAppt.RequiredAttendees & _
' """,""" & objAppt.OptionalAttendees & _
' """"
'BusyStatus (100:0=cancel/101:1=仮/102:2=OK/103:3=外出)
If CInt(objAppt.BusyStatus) <> 0 Then
' (cancel予定出なければ書き込み)
strLine = FormatDateTime(objAppt.Start, vbShortDate) & _
"," & FormatDateTime(objAppt.End, vbShortDate) & _
"," & FormatDateTime(objAppt.Start, vbShortTime) & _
"," & FormatDateTime(objAppt.End, vbShortTime) & _
",""" & objAppt.Subject & _
""",0,0,Asia/Tokyo,2,,0,,""" & objAppt.Location & _
""",0,0,0,,10" & vbCrLf

'stmCSVFile.WriteLine strLine
pre.WriteText (strLine)
'
End If
'
Set objAppt = colAppts.FindNext
Wend
'stmCSVFile.Close
' ADO
' バイナリモードにするためにPositionを一度0に戻す
' Readするためにはバイナリタイプでないといけない
pre.Position = 0
pre.Type = adTypeBinary
' Positionを3にしてから読み込むことで最初の3バイトをスキップする
' つまりBOMをスキップします
pre.Position = 3
Dim bin: bin = pre.Read()
pre.Close

' 読み込んだバイナリデータをバイナリデータとしてファイルに出力する
' ここは一般的な書き方なので説明を省略
Dim stm: Set stm = CreateObject("ADODB.Stream")
stm.Type = adTypeBinary
stm.Open
stm.Write (bin)
stm.SaveToFile strFileName, adSaveCreateOverWrite ' force overwrite
stm.Close
' ADODB(UTF-8) close
End Sub
'################################################################




(使い方)
(1) ↑このVBAスクリプトを適当な名前でセーブ
(2) outlook のマクロ登録方法にしたがって (1)を登録。
・デジタル署名もしておきましょう。
・ADODBを使うので「参照設定」→「Microsoft Active X Data Object」にチェックを。
(3) ジョルテで予定表をエクスポートしておく
(4) スマホを USB 接続 → どのドライブで見えるか確認
(5) 例えば G:\jorte というフォルダが見えて、そこに(3)のエクスポートファイル
(schedule_data.csv という名前) があるか確認
(6) outlook でマクロを実行。今月、来月分が schedule_data.csv というファイルに
出力される。
(7) (5)のドライブ、フォルダに、(6)の出力をコピー
(8) USB接続を切って、ジョルテで (7) をインポート


環境変数 JORTEDIR に (5) のフォルダを設定しておけば、直接(5)のフォルダに書き込むので (7)は不要になります。
JORTEDIR が設定されてなければ、環境変数 TEMP に設定されたフォルダに出力します。
TEMP も設定されてなければ c:\ に出力されます。ご参考まで。

AS YOUR OWN RISK で。
posted by opabee at 01:58| Comment(0) | TrackBack(0) | パソコン
この記事へのコメント
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

この記事へのトラックバックURL
http://blog.sakura.ne.jp/tb/54734060

この記事へのトラックバック