ちょっと便利な? カレンダー作成②
 作成するマクロは、『カレンダー作成.ods 』という名で保存する。

 マクロを実行すると、目的のカレンダーは別の新規ドキュメントとして作成され、最終的には「カレンダー20xx.ods」という名前をつけて保存される。


f0066555_17154475.jpg 1.カレンダー作成ドキュメントは、
左図のように3つのシートを持つ。



f0066555_17193010.jpg 2.プログラムシートは、
左図のように年を入力するセルと、『カレンダー作成』ボタンを配置。

 ボタンが押されると、指定の年のカレンダーを作成する。
 またこの年が保存するドキュメント名に使われる。


 3.modelシートには、前に作成したカレンダーのひな型が登録されている。
 このシートを新規ドキュメントにコピーし、さらに必要枚数をコピーする。

 実際には、A4用紙に2か月分を並べて印刷するため、必要枚数は6枚。



f0066555_17431564.jpg 4.paternシートには
左図のように、カレンダーの祝日につける赤丸、祝日の名称を表示するテキストシェイプなどが貼り付けてある。

 各シェイプは、日付が隠されないよう表面を透明に設定、テキストシェイプは枠線も邪魔なので白にしてある。

 この赤丸を祝日などに貼り付ける。



 【1】modelシートを元に新規ドキュメントを作成する。

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

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

  '---- カレンダーのひな型を新規ドキュメントにコピー ----
  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()


f0066555_20504715.jpg 以上の手順で、
左図のように新規ドキュメント『無題1』が作成される。
 ドキュメントに含まれるシートは、『プログラム作成』ドキュメントからコピーされた『model』シート1枚のみ。

 GetByIndex(1)の1は複数のシートの中の2枚目のシートのこと。 エクセルならシート番号は1から始まるので、2を指定する。
 同様に、エクセルではA1のセルは(1,1)だが、カルクでは(0,0)で始まる。 


 【2】.続いて、『無題ドキュメント』側で必要枚数分のカレンダーを作成する。

  '---- コピーしたシートの名前を変更 ----
  newSheet = newSheets.GetByIndex( 0 )
  newSheet.Name = "1月"

  '---- さらに必要枚数だけコピー ----
  newSheets.CopyByName( "1月", "3月", 32767)
  …

 32767はシートの最後にコピーする意味で、0ならシートの先頭になる。

 【3】さらに、各月のカレンダーに月初めの日付を設定する。

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

 ここでは、『カレンダー作成』ドキュメントの『program』シートのC8のセルから日付を読取る。

  '--- 各月の月初めの日付のセット ----
  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)
  …

 各シートには2か月分のカレンダーがあるので、D2とL2のセルに月初めの日付を入れている。

 以上で、まだ祝日などの赤丸がついていないが、12か月分の原型が完成。


 【蛇足1】Calc Basic で別のドキュメントにシートをコピーする

 インターネットを検索すると、私と同様にそのことで苦心されている人を見かける。(エクセルのVBAなら、なんと言うこともなくできるのに…)

 上記のコーディング例は、シート1枚を新規ドキュメントを作成すると同時にコピーしている。
 既存のドキュメントにコピーするのであれば

  '---- パラメータの設定 ----
  Dim array( 3 ) as new com.sun.star.beans.PropertyValue
  array( 0 ).Name = "DocName"
  array( 0 ).Value = "無題1"
  array( 1 ).Name = "Copy"
  array( 1 ).Value = true
  array( 2 ).Name = "Index"
  array( 2 ).Value = 32767

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

 とすることで、実現できる。


 【蛇足2】同様のことをエクセルのVBAでなら

 ずっと簡単にマクロが作成できてしまう。
 ↓





 ほとんど全体をだらだらと。

Option Explicit

 '=========== Excel のBook・シートなど =============
 '---- ひな型およびマークが保存されているドキュメント ----
 Public oDoc As Object
 Public oSheets As Object
 Public oSheet As Object

 '---- 新規に作成されるカレンダー ----
 Public nDoc As Object
 Public nSheets As Object
 Public nSheet As Object

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

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

 わずかだが使用している Sub や Function にいくつものパラメータを引き渡すのが面倒なので、グローバル変数とした。


Sub Main()
 '---- ひな型のドキュメントを取得 ----
 Set oDoc = ActiveWorkbook
 Set oSheets = oDoc.Worksheets

 '---- カレンダーを作成する側のドキュメントを作成 ----
 ThisWorkbook.Worksheets("model").Copy
 エクセルだと、シートを別のBookにコピーするのは、この1行ですむ。Copyの後に何も指定しなければ、新規Bookを作る。
 Set nDoc = ActiveWorkbook
 Set nSheets = nDoc.Worksheets

 '---- 作成するカレンダーの年度を取得 ----
 Set oSheet = oSheets("Program")
 YY = oSheet.Cells(8, 3).Value

 '---- 新規ドキュメント、6枚のカレンダー作成 ----
 CopyModel

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

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

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


'========= カレンダーのひな型をコピー ===========
Sub CopyModel()

 '---- 新規Bookのシートを、さらに5枚コピーする ----
 Set nSheet = nSheets(1)
 nSheet.Copy After:=nSheet
 …

 '---- 6枚のカレンダーを作成 ----
 Dim sName() As Variant
 sName() = Array("1月", "3月", "5月", "7月", "9月", "11月")
 Dim I As Integer
 For I = 0 To 5
  Set nSheet = nSheets(I + 1)
  nSheet.Name = sName(I)
  nSheet.Range("D2").Value = DateSerial(YY, I * 2 + 1, 1)
  nSheet.Range("L2").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)) = 1 Then
  '---- 振替休日 ---
  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 oldShapes As Object
 Dim oldShape As Object
 Dim trgDate As Date
 Dim trgCell As Object
 Dim trgShape As Object

 '---- 登録されているシェイプなどを取得 ----
 Set oSheet = oSheets("patern")
 Set oldShapes = oSheet.Shapes
 テキストShapeや丸印などは、登録順に1からの番号で取り出すことができる

 Dim I As Integer
 For I = 0 To CountHoliday - 1
  '------ 対象の祝日のセルを取得 ----
  trgDate = Holidays(I)
  Set trgCell = GetTrgCell(trgDate)

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

  '------ 数字を丸で囲む -------
  Set oldShape = oldShapes(25)
  oldShape.Copy
  nSheet.Paste
 Bookが異なるシート間の、Shapeのコピ・ペも実に簡単。(ただし、Calcの貼り付けはセルが対象なのだが、Excelはシートが対象)

  '----- 位置の微調整 -----
  Set trgShape = nSheet.Shapes(nSheet.Shapes.Count)
  trgShape.Top = trgCell.Top + 2
  trgShape.Left = trgCell.Left + 10
 Shapeの位置調整は、貼り付けたいセルの位置にする。(末尾の+2や+10は、Shapeがセルの左上隅になってしまうための調整)

  '-------- 祝日の説明書き ------
  If I > 14 Then
   Set oldShape = oldShapes(16) '--- 振替休日 ---
  Else
   Set oldShape = oldShapes(I + 1)
  End If
  oldShape.Copy
  nSheet.Paste
  …
 Next I
End Sub

 SetAniversaryは、ほとんど上記と同じなので省略。 以下は説明の要もないが、GetTrgCellでは、対象のセルを返しているだけでなく、グローバル変数のnSheetも変更されている。

'=========== 対象となるセルを取得 ============
Function GetTrgCell(trgDate As Date) As Range
 Dim MM As Integer
 Dim trgPos As Integer
 Dim trgDays As Integer
 Dim trgX As Integer
 Dim trgY As Integer

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

 '------- 日数から対象のセルを取得 ------
 trgDays = DateDiff("d", nSheet.Cells(4, trgPos).Value, trgDate)
 trgX = trgPos + trgDays Mod 7
 trgY = 4 + Int(trgDays / 7)
 Set GetTrgCell = nSheet.Cells(trgY, trgX)
End Function

'============= 終了時の処理 ============
Sub EndProc()
 '---- 作成したドキュメントを名前をつけて保存 ----
 Dim oldPath As String
 Dim fullPath As String

 fullPath = oldPath & "カレンダー" & YY & ".xls"
 If Dir(fullPath) <> "" Then
  MsgBox (fullPath & "は既に登録されています")
 Else
  nDoc.SaveAs (fullPath)
 End If

 oDoc.Close SaveChanges:=False
End Sub
[PR]
by t_ichib | 2013-01-15 22:00 | 今日もまた老年プログラマー
<< ちょっと便利な? カレンダー作成① ちょっと便利な? カレンダー作成③ >>