作成するマクロは、『カレンダー作成.ods 』という名で保存する。
マクロを実行すると、目的のカレンダーは別の新規ドキュメントとして作成され、最終的には「カレンダー20xx.ods」という名前をつけて保存される。 1.カレンダー作成ドキュメントは、 左図のように3つのシートを持つ。 2.プログラムシートは、 左図のように年を入力するセルと、『カレンダー作成』ボタンを配置。 ボタンが押されると、指定の年のカレンダーを作成する。 またこの年が保存するドキュメント名に使われる。 3.modelシートには、前に作成したカレンダーのひな型が登録されている。 このシートを新規ドキュメントにコピーし、さらに必要枚数をコピーする。 実際には、A4用紙に2か月分を並べて印刷するため、必要枚数は6枚。 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() 以上の手順で、 左図のように新規ドキュメント『無題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
by t_ichib
| 2013-01-15 22:00
| 今日もまた老年プログラマー
|
プロフィール
カテゴリ
以前の記事
その他のジャンル
記事ランキング
|
ファン申請 |
||