ちょっと便利な? カレンダー作成③
 【4】1年間の祝日を洗い出す

 1年間の祝日には春分・秋分の日などや、第2・第3月曜に決められた成人の日など、振替休日など日付が変わるものがある。
 といっても面倒なだけで、難しいところはない。

 実際のコーディングは【蛇足】を参照。


 【5】祝日のフォント・赤丸・祝日名などを、カレンダーに貼り付ける。

 祝日・記念日のセルの位置は、GetTrgCellを使って取得している。

 テキストShapeや丸印などは、PaternシートのDrawPageにあり、登録順の番号で取得できる。
 このときの番号は、シート番号などと同様に0から始まる。(Excelでは1から)

 さらに、ExcelではShapeをシートに貼り付けたが、Calcではセルを指定して張り付ける。

f0066555_1203723.jpg
 シェイプは左図のように、セルの左上に貼り付けられてしまう。
 これではみっともないので、位置の修正をする。

 その微調整でも、Excelはたぶんピクセル単位だが、Calcでは1/100ミリ単位とかで違っている。
 VBAからCalcに移植しようとして四苦八苦しているさまを目にするが、私はその逆。 戸惑うことも多いが、「こんなに簡単!」と思うことの方が多い。


f0066555_1320161.jpg 以上の手順で、左図のようなカレンダーが作成される。
 (5/9の星印は孫の誕生日)


 【6】仕上げ

 完成したカレンダーを、『カレンダー20xx.ods』という名前で保存する。
 マクロが入った『カレンダー作成.ods』は閉じる。


 【蛇足】Calcのコーディング

 本文ではコーディングを省いたので、興味があれば是非に。
 ↓






 Excelでしたように、Calcのコーディングのほぼ全体を、最初にグローバル変数を定義しているのは、Sub・Functionで、たくさんのパラメータを使わなくてもすむようにと。

 Option Explicit
 '=========== マクロ実行のため ==================
 Dim Disptch as Object

 '=========== Calc のドキュメント・シートなど =============
 '---- ひな型およびマークが保存されているドキュメント ----
 Public oldDoc as Object
 Public oldSheets as Object
 Public oldSheet as Object
 public oldController as Object

 '---- 新規に作成されるカレンダー ----
 Public newDoc as Object
 Public newSheets as Object
 Public newSheet as Object
 public newController as Object

 '=========== 作成するカレンダーの年度 ============
 Public YY as Integer

 '=========== 祝日 & 記念日 & 祝日数 =============
 Public Holidays( 20 ) as Date
 Public Aniversarys( 8 ) as Date
 Public CountHoliday as Integer

Sub Main
 '---- Dispatcherの取得 -------
 Disptch = createUnoService( "com.sun.star.frame.DispatchHelper" )

 '---- ひな型のドキュメントを取得 ----
 oldDoc = ThisComponent
 oldSheets = oldDoc.GetSheets()
 oldController = oldDoc.GetCurrentController()

 '---- カレンダーのひな型を新規ドキュメントにコピー ----
 oldSheet = oldSheets.GetByIndex( 1 )
 oldController.SetActiveSheet(oldSheet)

 Dim array( 2 ) as new com.sun.star.beans.PropertyValue
 array( 0 ).Name = "DocName"
 array( 0 ).Value = ""
 array( 1 ).Name = "Copy"
 array( 1 ).Value = true

 Disptch.executeDispatch( oldController.Frame, ".uno:Move", "", 0, array() )

 '---- 新規作成したドキュメントの対応付け ----
 newDoc = starDesktop.CurrentComponent
 newSheets = newDoc.GetSheets()
 newController = newDoc.GetCurrentController()

 '---- 作成するカレンダーの年度を取得 ----
 oldSheet = oldSheets.GetByIndex( 0 )
 YY = oldSheet.GetCellByPosition( 2, 7 ).Value

 '---- 新規ドキュメントへのシートのコピー ----
 CopyModel()

 '---- その年度の祝日・振替休日・記念日を取得する ----
 GetHoliday()

 '---- 祝日および記念日をカレンダーに表示 ----
 SetHoliday()
 SetAniversary()

 '---- 終了処理 ----
 EndProc()
End Sub

'============ カレンダーのひな型をコピー ==========
Sub CopyModel
 '---- コピーしたシートの名前を変更 ----
 newSheet = newSheets.GetByIndex( 0 )
 newSheet.Name = "1月"

 '---- さらに必要枚数だけコピー ----
 newSheets.CopyByName( "1月", "3月", 32767)
 newSheets.CopyByName( "1月", "5月", 32767)
 …
 '--- 各月の月初めの日付のセット ----
 Dim I as Integer
 For I = 0 to 5
  newSheet = newSheets.GetByIndex( I )
  newSheet.GetCellByPosition(3,1).Value = DateSerial(YY,I*2+1,1)
  newSheet.GetCellByPosition(11, 1).Value = DateSerial(YY,I*2+2,1)
 Next I
End Sub

'=========== 祝日および記念日の日付を取得する ========
Sub GetHoliday ()
 Dim wrkDate as Date
 Dim wrkDay as integer

 '---------- 振替休日がないときの祝日数 --------
 CountHoliday = 15
 '---------- 元旦 -------
 Holidays(0) = DateSerial(YY, 1, 1)
 If Weekday(Holidays(0))= 1then
  '---- 振替休日 ---
  Holidays(CountHoliday) = DateSerial(YY, 1, 2)
  CountHoliday = CountHoliday + 1
 End If
 '---------- 成人の日 -------
 wrkDate = DateSerial(YY, 1, 8)
 wrkDay = Weekday(wrkDate)
 If wrkDay = 2 then
  Holidays(1) = wrkDate
 ElseIf wrkDay = 1 then
  Holidays(1) = wrkDate + 1
 Else
  Holidays(1) = wrkDate + 9 - wrkDay
 End If
 …
 '---------- 春分の日 -------
 wrkDay = int(20.843 + 0.242194 * (YY - 1980) - int((yy - 1980) / 4)
 Holidays(3) = DateSerial(yy, 3, wrkDay)
 …
 '---------- 秋分の日 -------
 wrkDay = int(23.2488 + 0.242194 *(YY - 1980) - int((yy - 1980)/ 4)
 Holidays(10) = DateSerial(yy,9,wrkDay)
 …
 '---------- 誕生日・家族の記念日 -------
 Aniversarys( 0 ) = DateSerial( YY, ?, ? )
End Sub

 振替休日のコーディングは繰り返しになるので、省略した。
 成人・海・敬老・体育の日、および憲法記念日・みどりの日には、振替休日はない。


'============ 祝日をセットする ===========
Sub SetHoliday
 Dim oldDrawPage as Object
 Dim oldDraw As Object

 Dim trgDrawPage as Object
 Dim trgDraw as Object
 Dim trgPos As New com.sun.star.awt.Point

 Dim trgCell as Object
 Dim Dummy()

 '---- 登録されているシェイプなどを取得 ----
 oldSheet =oldSheets.GetByName( "patern" )
 oldDrawPage = oldSheet.GetDrawPage()

 Dim I as Integer
 For I = 0 to CountHoliday - 1
  '------ 対象の祝日のセルを取得 ----
  trgCell = GetTrgCell( HoliDays( I ) )

  '------ 祝日のフォントを赤に ----
  trgCell.CharColor = RGB( 255, 0, 0 )

  '------ 数字を丸で囲む -------
  oldDraw = oldDrawPage.GetByIndex( 24 )
  oldController.select( oldDraw )
  Disptch.executeDispatch( oldController.Frame, ".uno:Copy", "", 0, Dummy() )
  newController.Select( trgCell )
  Disptch.executeDispatch( newController.Frame, ".uno:Paste", "", 0, Dummy() )
 異なるドキュメント間のShapeのコピ・ペなので、それぞれのドキュメントに関連付けられたoldController、newControllerを使っていることに注意。

  '--------- 貼り付けたマークの位置を調整する -----
  trgDrawPage = newSheet.getDrawPage
  trgDraw = trgDrawPage.GetByIndex( trgDrawPage.GetCount() - 1 )
  trgpos = trgDraw.GetPosition()
  trgPos.X = trgPos.X + 300
  trgPos.Y = trgPos.Y + 50
  trgDraw.SetPosition( trgPos )
 DrawPageは各シートごとにあるので、OldDrawPageとは別物、直前に貼り付けたものはGetCount() - 1 の番号で取得できる。
  '-------- 祝日の説明書き ------
  If I > 14 then
   oldDraw = oldDrawPage.GetByIndex( 15 )'--- 振替休日 ---
  Else
   oldDraw = oldDrawPage.GetByIndex( I )
  End If
  oldController.select( oldDraw )
  Disptch.executeDispatch( oldController.Frame, ".uno:Copy", "", 0, Dummy() )
  newController.Select( trgCell )
  Disptch.executeDispatch( newController.Frame, ".uno:Paste", "", 0, Dummy() )
 Next I
End Sub

'=== 対象となるセルを取得 《注 newSheetも切り替わる》 =====
Function GetTrgCell (trgDate as Date) as Object
 Dim MM as Integer
 Dim trgPos as integer
 Dim trgDays as Integer
 Dim trgX as integer
 Dim trgY as integer

 '-------- 月から対象のシートおよび左右を取得 ------
 MM = Month(trgDate)
 newSheet = newSheets.GetByIndex(Int((MM - 1) / 2))
 trgPos = 8 * ( (MM - 1) Mod 2)

 '------- 日数から対象のセルを取得 ------
 trgDays = trgDate - newSheet.GetCellByPosition(trgPos, 3).Value
 trgX = trgPos + trgDays Mod 7
 trgY = 3 + Int(trgDays / 7)
 GetTrgCell = newSheet.GetCellByPosition(trgX, trgY)
End Function

'============ 終了時の処理 ===========
Sub EndProc
 '---- 作成したドキュメントを名前をつけて保存 ----
 Dim oldURL as String
 Dim oldPath as String
 Dim oldName as String
 Dim newURL as String
 Dim newPath as String
 Dim newName as String

 Dim Dumy()

 oldURL = oldDoc.URL
 oldPath = ConvertFromURL(oldURL )
 oldName = oldDoc.Title
 newName = "カレンダー" + YY + ".ods"
 newPath = Left( oldPath, Len( oldPath ) - Len( oldName ) ) + newName
 newURL = convertToURL( newPath )
 If FileExists( NewURL ) Then
  msgBox( newPath + "は既に登録されています" )
 Else
  newDoc.StoreAsURL( newURL, Dumy() )
 End If

 '---- ファイルのクローズ ----
 oldDoc.Dispose()
End Sub
[PR]
by t_ichib | 2013-01-15 19:55 | 今日もまた老年プログラマー
<< ちょっと便利な? カレンダー作成② 結婚式のついでに⑤ 最終日 >>