CreateCybozuItem.vbs v0.01のバックアップ

' CreateCybozuItem.vbs v0.01
' Copyright (C) 2007 甘党のプログラマ, All rights reserved.
'v0.01 (2007/10/24) 
'初版-サイボウズの予定作成のみ対応。

Option Explicit 
const VBS_TITLE = "CreateCybozuItem.vbs v0.01"

Dim strUrlPath, strUrlPage, strUrlId, strUrlGid, strUrlData, strUrlBpage, strUrlBdate
Dim strAppActivate
strUrlPath = "http://★.★.★.★//scripts/cb3/office.exe"
strUrlPage = "page=ScheduleEntry"
strUrlId = "id=★"
strUrlGid = "gid=★" 
strAppActivate = "★★★ - スケジュールの登録 - Microsoft Internet Explorer" 
Dim objWshUnnamed
Set objWshUnnamed = WScript.Arguments.Unnamed
Dim objWshNamed
Set objWshNamed = WScript.Arguments.Named
Dim enumItemType 
(0:olMailItem/1:olAppointmentItem/3:olTaskItem/4:olNoteItem)
Dim strItemType
Dim strInputFile  ' 入力ファイル名

Dim objFso
Dim objStream

Dim objIE
Dim strUrl

Dim boolDelFileFlag
boolDelFileFlag = False
Dim boolContProcFlag
boolContProcFlag = True
Dim boolFindStat
boolFindStat = False

Dim oRe, oMatch, oMatches, RetStr
Dim idxFindPos
Dim strYear ,strMon, strDay
Dim strHour, strMin

Dim objWSHShell
Dim strBody
Dim Idx

If objWshUnnamed.Count <> 2 Then
 DispUsage
 boolContProcFlag = False
Else
 Select Case objWshUnnamed(0)
  Case "appo"
   enumItemType = 1 'olAppointmentItem
   strItemType = "予定"
  Case Else
   DispUsage
   boolContProcFlag = False
 End Select

 strInputFile = objWshUnnamed(1)

 If objWshNamed.Exists("DEL") Then boolDelFileFlag=True

 If boolContProcFlag = True Then
  Set objFso = CreateObject("Scripting.FileSystemObject")
  If objFSO.FileExists(strInputFile) Then
   Set objStream = objFso.OpenTextFile(strInputFile , 1)
   strBody = objStream.ReadAll()
   strYear = Year(Now)
   strMon = Month(Now)
   strDay = Day(Now)
   strHour = Hour(Now)
   If (Minute(Now)<30) Then 
    strMin = 0
   Else
    strMin = 30
   End If

   ' 月/日のパターン
   Set oRe = New RegExp
   oRe.Pattern = "([0-9]+)/([0-9]+)"
   Set oMatches = oRe.Execute(strBody)
   If oMatches.Count > 0 Then
    Set oMatch = oMatches(0)
    strMon = oMatch.SubMatches(0)
    strDay = oMatch.SubMatches(1)
    idxFindPos = oMatch.FirstIndex
   Else
    idxFindPos = -1
   End If
   ' mm月dd日のパターン
   oRe.Pattern = "([0-9]+)月 +([0-9]+)日"
   Set oMatches = oRe.Execute(strBody)
   If oMatches.Count > 0 Then
    Set oMatch = oMatches(0)
    If (oMatch.FirstIndex <idxFindPos) Then
     strMon = oMatch.SubMatches(0)
     strDay = oMatch.SubMatches(1)
     idxFindPos = oMatch.FirstIndex
    End If
   Else
    idxFindPos = -1
   End If
   ' 時:分のパターン
   oRe.Pattern = "([0-9]+):([0-9]+)"
   Set oMatches = oRe.Execute(strBody)
   If oMatches.Count > 0 Then
    Set oMatch = oMatches(0)
    strHour = oMatch.SubMatches(0)
    strMin = oMatch.SubMatches(1)
    idxFindPos = oMatch.FirstIndex
   Else
    idxFindPos = -1
   End If
   ' h時m分のパターン
   oRe.Pattern = "([0-9]+)時 +([0-9]+)分"
   Set oMatches = oRe.Execute(strBody)
   If oMatches.Count > 0 Then
    Set oMatch = oMatches(0)
    If (oMatch.FirstIndex <idxFindPos) Then
     strHour = oMatch.SubMatches(0)
     strMin = oMatch.SubMatches(1)
     idxFindPos = oMatch.FirstIndex
    End If
   Else
    idxFindPos = -1
   End If
   ' URLの生成
   strUrlData = "date=da." & Year(Now) & "." & Month(Now) & "." & Day(Now)
   strUrlData = "date=da." & strYear & "." & strMon & "." & strDay
   strUrlBpage = "bpage=ScheduleDay"
   strUrlBdate = "bdate=da." & strYear & "." & strMon & "." & strDay
   strUrl = strUrlPath & "?" & strUrlPage & "&" & strUrlId & "&" & strUrlGid & "&" & strUrlData & "&" & strUrlBpage & "&" & strUrlBdate
   Set objWSHShell = WScript.CreateObject("WScript.Shell")
   ' IEのインスタンスを生成
   set objIE = WScript.CreateObject("InternetExplorer.Application")
      With objIE
          .Visible = True
    .Navigate(strUrl)
    Do While .busy
    Loop
    Do While .Document.readyState <> "complete"
    Loop

    ' ウィンドウの切替
    boolFindStat = objWSHShell.AppActivate( strAppActivate )
    If  boolFindStat = False Then
     MsgBox("debug cannot find ie window")
    End If

    WScript.Sleep 1000

    'メモへの入力は、Shift+Tab 9回
          objWSHShell.SendKeys "+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}"
    ' クリップボードの内容をペースト
          objWSHShell.SendKeys "+{INSERT}"
          objWSHShell.SendKeys "^{HOME}"
   '予定(タイトル)の入力は、さらに、Shift+Tab 3回
          objWSHShell.SendKeys "+{TAB}+{TAB}+{TAB}"
    ' クリップボードの内容をペースト
          objWSHShell.SendKeys "+{INSERT}"
    '開始時刻の時間は、Shift+Tab 5回
          objWSHShell.SendKeys "+{TAB}+{TAB}+{TAB}+{TAB}+{TAB}"
    '8時以降は、↓をstrHour-7回
    If strHour > 7 Then
     For Idx = 1 To (strHour-7)
      objWSHShell.SendKeys "{DOWN}"
     Next
    Else
     ' 7時以前は、1回↓のあと、↑を9-strHour回
     objWSHShell.SendKeys "{DOWN}"
     For Idx = 1 To (9-strHour)
      objWSHShell.SendKeys "{UP}"
     Next
    End If
    '開始時刻の分に、移動(Tab 1回)
          objWSHShell.SendKeys "{TAB}"
    '00は、↓1回
    For Idx = 1 To (strMin/15)+1
     objWSHShell.SendKeys "{DOWN}"
    Next
    '終了時刻に移動(Tab 1回)
          objWSHShell.SendKeys "{TAB}"
    '終了時刻は、開始の+1時間にしておく、移動(Tab 1回)
    If (strHour+1) > 7 Then
     For Idx = 1 To ((strHour+1)-7)
      objWSHShell.SendKeys "{DOWN}"
     Next
    Else
     ' 7時以前は、1回↓のあと、↑を9-(strHour+1)回
     objWSHShell.SendKeys "{DOWN}"
     For Idx = 1 To (9-(strHour+1))
      objWSHShell.SendKeys "{UP}"
     Next
    End If
    '終了時刻の分に、移動(Tab 1回)
          objWSHShell.SendKeys "{TAB}"
    '00は、↓1回
    For Idx = 1 To (strMin/15)+1
     objWSHShell.SendKeys "{DOWN}"
    Next
    ' Shift Tabで、終了時刻の時間に戻る
          objWSHShell.SendKeys "+{TAB}"
   End With
  Else
   ' システムがエラーを出すか?
  End If
 End If
End If
WScript.Quit (1)

Private Sub DispUsage
 MsgBox _
   "○ 使用方法" & vbCrLf & _
  "wscript.exe CreateCybozuItem.vbs item-type filename " & vbCrLf & _
  "  item-type=appo" & vbCrLf & _
  "○ 機能" & vbCrLf & _
  "item-typeに指定されたサイボウズv3のアイテム作成します。" & vbCrLf _
 ,, VBS_TITLE
End Sub