[[20120310233201]]　『ﾕｰｻﾞｰホームにカレンダを表示したい』（唯一無二）　ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

　

『ﾕｰｻﾞｰホームにカレンダを表示したい』（唯一無二）

 Excel2003　　WindowsXPを使用しています。 
 よろしくお願いします。

 本学校で色々検索したり、教えて頂いて自動で見やすいカレンダを表示させ
 色々な場面で活用させて頂いています

　

	A	B	C	D	E	F	G
1	2012	 3					
2	日	月	火	水	木	金	土
3					 1	 2	 3
4	 4	 5	 6	 7	 8	 9	10
5	11	12	13	14	15	16	17
6	18	19	20	21	22	23	24
7	25	26	27	28	29	30	31
8							
9							
 Ａ１に関数で今の年（yyyyy）Ｂ１に今の月（ｍｍ）が表示しています
 各セルには日付が表示しています
 本日は３月１０日（土曜日）です。関数の構文でセルの色が黄色になります。

 関数やセルの書式設定で
 基本的には
 Ａ３：Ａ９（日）の文字は赤
 Ｇ３：Ｇ（土）の文字は青
 別のセルの祝日一覧を配置しており
 祝日の文字は赤（２０日：春分の日）表示

 本日（２０１２年３月１０日＜土＞）セルは黄色（１０日）になっています。

 上記のようなカレンダをシート上に表示させ「図のリンク貼り付け」でシートの任意の
 ところに貼り付け,便利に使わせて頂いています。
 今日の質問ですが、このカレンダを「図のリンク貼り付け」の状態をﾕｰｻﾞｰホーム上に表示したいと思い質問させて頂きました。
 まず、出来るか否かですが、出来るのでしたらどのようにすればいいかを教えて頂け
ないでしょうか。 どうしても表示の整形がうまくいきません。見にくくてすみませ
んが よろしくお願いします。

---

 ユーザーフォーム上に、指定領域のセルを指定して｢図としてリンク貼付｣を行うことはできない（と思う）ので
 あくまで、その時点での状態を取り込むことでよければ以下のような方法が考えられる。
 実際には、ユーザーフォーム表示中にカレンダーがかわるということはないと思うので、それで充分のような気がする。

 １．通常の図として取り込む
 ２．シート上のカレンダー領域の各セル（５６セル）を、ユーザーフォーム上のLabelコントロールに色書式も考慮して転記。
　　５６個のラベルをデザインで配置しておくことが面倒ならコード内で８行、７列のラベルを自動生成することもできる。

 上記、いずれも、必要なら、ユーザーフォームにコマンドボタンを配置して、再取り込みをさせることもできる。

 (ぶらっと)

---

 あまり使用するメリットはありませんが 
 >このカレンダを「図のリンク貼り付け」の状態
表示だけで良いのなら（古すぎて知らないかもしれないが）ダイアログシート
なら貼り付け可能です。
(PON)

---

 画像として取り込む方法は、(PON)さんのコメント、私のコメントなど、いくつか方法があるけど
 「遊び」で、私のコメントの２．を。
 カラッポのユーザーフォームを用意して、そのユーザーフォームモジュールに以下を。
 このフォームがモードレス表示されていて、ユーザーフォーム表示中にカレンダー領域の内容が変更された場合に
 その変更の状態を再度取り込む必要があれば、ユーザーフォームの「セル枠以外のところ」をクリック。

 Private Sub UserForm_Initialize()
    Dim h As Double, w As Double, l As Double, t As Double
    Dim i As Long, j As Long

    h = Me.InsideHeight / 8
    w = Me.InsideWidth / 7

    For i = 1 To 8
        l = 0
        For j = 1 To 7
            With Me.Controls.Add("Forms.Label.1", "lbl_" & i & "_" & j)
                .Left = l: .Top = t: .Width = w: .Height = h
                l = l + w
                .SpecialEffect = fmSpecialEffectSunken
                .TextAlign = fmTextAlignCenter
            End With
        Next
        t = t + h
    Next

    Call ReMake

 End Sub

 Private Sub UserForm_Click()
    Call ReMake
 End Sub

 Sub ReMake()
    Dim h As Double, w As Double, l As Double, t As Double
    Dim i As Long, j As Long
    Dim myStr As String
    Dim myBColor As Long
    Dim myFColor As Long

    For i = 1 To 8
        For j = 1 To 7

            With Sheets("Sheet1").Cells(i, j)
                myStr = .Text
                myBColor = .Interior.Color
                myFColor = .Font.Color
            End With

            With Me.Controls("lbl_" & i & "_" & j)
                If Len(myStr) = 0 Then
                    .Visible = False
                Else
                    .Visible = True
                    .BackColor = myBColor
                    .ForeColor = myFColor
                    .Caption = myStr
                End If
            End With

        Next
    Next

 End Sub

 (ぶらっと)

---

 もし、そのユーザーフォームにほかのものもあって、「カレンダーも」表示させるのなら、
Frame1を、カレンダーを表示させたい場所に配置して以下。　
なお、再取り込みはCommandButton1を押して実行。

 Private Sub UserForm_Initialize()
    Dim h As Double, w As Double, l As Double, t As Double
    Dim i As Long, j As Long

    With Me.Frame1
        h = .InsideHeight / 8
        w = .InsideWidth / 7
        .Caption = ""
    End With

    CommandButton1.Caption = "最新の状態を反映"

    For i = 1 To 8
        l = 0
        For j = 1 To 7
            With Me.Frame1.Add("Forms.Label.1", "lbl_" & i & "_" & j)
                .Left = l: .Top = t: .Width = w: .Height = h
                l = l + w
                .SpecialEffect = fmSpecialEffectSunken
                .TextAlign = fmTextAlignCenter
            End With
        Next
        t = t + h
    Next

    Call ReMake

 End Sub

 Private Sub CommandButton1_Click()
    ReMake
 End Sub

 Sub ReMake()
    Dim h As Double, w As Double, l As Double, t As Double
    Dim i As Long, j As Long
    Dim myStr As String
    Dim myBColor As Long
    Dim myFColor As Long

    For i = 1 To 8
        For j = 1 To 7

            With Sheets("Sheet1").Cells(i, j)
                myStr = .Text
                myBColor = .Interior.Color
                myFColor = .Font.Color
            End With

            With Me.Controls("lbl_" & i & "_" & j)
                If Len(myStr) = 0 Then
                    .Visible = False
                Else
                    .Visible = True
                    .BackColor = myBColor
                    .ForeColor = myFColor
                    .Caption = myStr
                End If
            End With

        Next
    Next

 End Sub

 (ぶらっと)

---

 そのほか、ListViewコントロールを使う方法もあるし、また2003までなら、SpreadSheetコントロールを使う方法もあるね。

 (ぶらっと)

---

 ぶらっとさん、PONさん。
 ご支援頂きありがとうございます。
 教えて頂いた方法、具体的にどうすればいいのかわかりませんので
 もう少し、自分で確認してから再度質問させて頂きます。
 とりあえず、お礼だけですすが、きありがとうございました。
 （唯一無二）11日11:45

---

 図形としてユーザーフォームに貼り付ける方法です。
 ユーザーフォームを一つ用意してください（UserForm1）。
 コントロールは、コードで配置しますから、何も配置しないでください。

 では、コードです。

 標準モジュールに

 Sub 図の表示()
    Const Graghfl = "graph.gif"
    Dim pic As Object
    Dim rng As Range
    Set rng = Range("A1:G7")
    With ActiveSheet.ChartObjects.Add(100, 100, rng.Width, rng.Height)
        .Activate
        .Chart.ChartArea.Border.LineStyle = 0
        .Chart.ChartArea.ClearContents
        .Chart.ChartArea.Select
        rng.Copy
        Set pic = .Chart.Pictures.Paste
        pic.Width = .Width
        pic.Height = .Height
        .Height = pic.Height + (.Chart.ChartArea.Top) * 2
        .Width = pic.Width + (.Chart.ChartArea.Left) * 2
        .Chart.Export ThisWorkbook.Path & "\" & Graghfl
        .Delete
    End With
    With UserForm1
       .imgpath = ThisWorkbook.Path & "\" & Graghfl
       .imgwidth = rng.Width
       .imgheight = rng.Height
       .imginst
       .Width = rng.Width + 10
       .Height = rng.Height + 200
       .Show vbModeless
    End With
    Kill ThisWorkbook.Path & "\" & Graghfl
 End Sub

 UserForm1のモジュールに

 '=============================================
 Option Explicit
 Public imgpath As Variant
 Public imgwidth As Single
 Public imgheight As Single
 Sub imginst()
    On Error Resume Next
    Dim img1 As Control
    Set img1 = Controls("image1")
    If Err.Number <> 0 Then
       Set img1 = Controls.Add("Forms.Image.1", "image1", True)
    End If
    On Error GoTo 0
    With img1
       .Picture = LoadPicture(imgpath)
       .Left = 0
       .Top = 0
       .Width = imgwidth
       .Height = imgheight
    End With
 End Sub

 アクティブシートのA1:G7にカレンダーがあるとします。

 尚、ThisWorkbook.Path　を使っていますから、一度保存してから、
 実行してみてください。

 APIを使えば、ファイルを介さなくても可能ですが、こっちの方が
 簡単なので今回は、ファイルを介しました。

 ichinose@グラフィックフィルタが壊れてた、コードを書いて試してよかった

---

ユーザーフォームを用意して下記コードを貼付けて下さい（マナ）

 他の板で恐縮ですが、API部分は↓の藤代千尋さんの最後のレスのコードをそのまま利用
 http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+200901/09010018.txt

 長いけどAPI部分は、そのままコピペして使い回せるので、実は楽ちん。
 最後のPrivate Sub UserForm_Initialize()を適当にアレンジして使用して下さい。

 Option Explicit

 Private Const CF_METAFILEPICT = 3
 Private Const CF_ENHMETAFILE = 14
 Private Declare Function OpenClipboard Lib "user32.dll" _
                (ByVal hWnd As Long) As Long
 Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" _
                (ByVal wFormat As Long) As Long
 Private Declare Function GetClipboardData Lib "user32.dll" _
                (ByVal wFormat As Long) As Long
 Private Declare Function CloseClipboard Lib "user32.dll" () As Long
 Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" _
                (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
 Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
                (ByVal hemf As Long) As Long

 Private Const vbPicTypeEMetafile = 4
 Private Type TPICTDESC
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    Option1 As Long
    Option2 As Long
 End Type

 Private Type TGUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(1 To 8) As Byte
 End Type

 Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
                            (lpPictDesc As TPICTDESC, _
                             RefIID As TGUID, _
                             ByVal fPictureOwnsHandle As Long, _
                             ByRef IPic As stdole.IPictureDisp) As Long

 Public Function Clipboard_GetMetafile() As stdole.IPictureDisp
    Dim hemf As Long
    Dim TPICTDESC As TPICTDESC
    Dim TGUID As TGUID

    Set Clipboard_GetMetafile = Nothing

    If IsClipboardFormatAvailable(CF_ENHMETAFILE) = False Then Exit Function
    If OpenClipboard(CLng(0)) = False Then Exit Function

    hemf = GetClipboardData(CF_ENHMETAFILE)
    If hemf = 0 Then
        Call CloseClipboard
        Exit Function
    End If

    hemf = CopyEnhMetaFile(hemf, vbNullString)
    Call CloseClipboard
    If hemf = 0 Then Exit Function

    With TPICTDESC
        .cbSizeofStruct = Len(TPICTDESC)
        .picType = vbPicTypeEMetafile
        .hImage = hemf
    End With
    With TGUID
        .Data1 = &H7BF80981
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(1) = &H8B
        .Data4(2) = &HBB
        .Data4(3) = &H0
        .Data4(4) = &HAA
        .Data4(5) = &H0
        .Data4(6) = &H30
        .Data4(7) = &HC
        .Data4(8) = &HAB
    End With
    Call OleCreatePictureIndirect(TPICTDESC, TGUID, True, Clipboard_GetMetafile)
 End Function

 '********以下を必要に応じて修正する******************

 Private Sub UserForm_Initialize()
    Sheets("Sheet1").Range("A1:G7").CopyPicture _
	Appearance:=xlScreen, Format:=xlPicture
    Picture = Clipboard_GetMetafile()
    PictureSizeMode = 3  '1:fmPictureSizeModeStretch, 3:fmPictureSizeModeZoom
 End Sub

---

 こんばんは　(UO3)です。 (HNは、この場所でよかったですか？）
いつも、楽しく拝見しています。

 私からも、過去にエキスパートさんから教えていただいたコードをアップさせていただこうとしましたら
(マナ)さんから、ほぼ同じ運びのものがアップされていました。
記憶では、私のものは、藤代千尋さんではなく（藤代千尋さんにも、常日頃ご指導いただいていますが）
別の方からのご指導でしたけど。

 ユーザーフォームにImage11を配置してください。
シートのA1:G8がカレンダー領域のようですので、その領域をイメージにして取り込みます。
(マナ)さんのコードと同じく、Image1の大きさに合わせてZoomしていますので、見栄えがいいように、Image1の大きさは、調整願います。

 ユーザーフォームモジュールに以下を貼り付けてお試しください。
　
Option Explicit
　
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type UPICDESC
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
  Reserved As Long
End Type
　
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picdesc As UPICDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hmf As Long) As Long
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function CopyImage Lib "user32" (ByVal Handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Const CF_ENHMETAFILE = 14
Const PICTYPE_ENHMETAFILE = 4
Const CF_BITMAP = 2 '=xlBitmap
Const PICTYPE_BITMAP = 1
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = 4
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
　
Private Sub UserForm_Initialize()
    Dim im As Object
    Dim h As Long
    Dim w As Long

    Sheets("Sheet1").Range("A1:G8").CopyPicture     'シート名は実際のものに変更願います
    With Image1
        .PictureSizeMode = fmPictureSizeModeZoom
        Set .Picture = GetPicture(xlPicture)
    End With
End Sub
　
Private Function GetPicture(ByVal Format As XlCopyPictureFormat) As IPicture
  Dim Handle&, desc As UPICDESC, id As GUID
  If OpenClipboard(0&) > 0 Then
    If Format = xlBitmap Then
      Handle = CopyImage(GetClipboardData(CF_BITMAP), IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    Else
      Handle = CopyEnhMetaFile(GetClipboardData(CF_ENHMETAFILE), vbNullString)
    End If
    CloseClipboard
  End If
  If Handle = 0 Then Exit Function 'イメージ取得失敗
  IIDFromString StrConv("{7BF80981-BF32-101A-8BBB-00AA00300CAB}", vbUnicode), id
  With desc
    .Size = Len(desc)
    .Type = IIf(Format = xlBitmap, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
    .hPic = Handle
  End With
  'Pictureオブジェクトを作成
  OleCreatePictureIndirect desc, id, 1, GetPicture
  If GetPicture Is Nothing Then
    If Format = xlBitmap Then DeleteObject Handle Else DeleteEnhMetaFile Handle
  End If
End Function

---

コメント返信：

---

[ 一覧(最新更新順) ]

---

YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.