Results of 1 - 1 of about 1240 for カレンダー (0.001 sec.)
- [[20120310233201]]
- #score: 6122
- @digest: 7f65fa3499fc0ed421710b36240f651e
- @id: 58074
- @mdate: 2012-03-11T13:12:20Z
- @size: 15202
- @type: text/plain
- #keywords: mybcolor (44989), myfcolor (44989), tpictdesc (43904), enhmetafile (38819), pictype (38319), remake (28853), copyenhmetafile (28021), graghfl (27066), getmetafile (27066), tguid (26361), hemf (26361), getclipboarddata (23618), getpicture (22852), handle (21899), xlbitmap (20624), olecreatepictureindirect (20449), 代千 (19398), data4 (19201), closeclipboard (17948), wformat (15602), openclipboard (14358), chartarea (14094), bitmap (13969), clipboard (13578), declare (12303), gdi32 (11826), user32 (8393), image1 (7906), double (5452), カレ (5419), function (5384), private (4282)
- 『ユーザーホームにカレンダを表示したい』（唯一無二）
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 A1に関数で今の年（yyyyy）B1に今の月（mm）が表示しています 各セルには日付が表示しています 本日は3月10日（土曜日）です。関数の構文でセルの色が黄色になります。 関数やセルの書式設定で 基本的には A3:A9（日）の文字は赤 G3:G（土）の文字は青 別のセルの祝日一覧を配置しており 祝日の文字は赤（20日:春分の日）表示 本日（2012年3月10日＜土＞）セルは黄色（10日）になっています。 上記のようなカレンダをシート上に表示させ「図のリンク貼り付け」でシートの任意の ところに貼り付け,便利に使わせて頂いています。 今日の質問ですが、このカレンダを「図のリンク貼り付け」の状態をユーザーホーム上に表示したいと思い質問させて頂きました。 まず、出来るか否かですが、出来るのでしたらどのようにすればいいかを教えて頂け ないでしょうか。 どうしても表示の整形がうまくいきません。見にくくてすみませ んが よろしくお願いします。 ---- ユーザーフォーム上に、指定領域のセルを指定して「図としてリンク貼付」を行うことはできない（と思う）ので あくまで、その時点での状態を取り込むことでよければ以下のような方法が考えられる。 実際には、ユーザーフォーム表示中にカレンダーがかわるということはないと思うので、それで充分のような気がする。 1.通常の図として取り込む 2.シート上のカレンダー領域の各セル（56セル）を、ユーザーフォーム上のLabelコントロールに色書式も考慮して転記。 56個のラベルをデザインで配置しておくことが面倒ならコード内で8行、7列のラベルを自動生成することもできる。 上記、いずれも、必要なら、ユーザーフォームにコマンドボタンを配置して、再取り込みをさせることもできる。 (ぶらっと) ---- あまり使用するメリットはありませんが >このカレンダを「図のリンク貼り付け」の状態 表示だけで良いのなら（古すぎて知らないかもしれないが）ダイアログシート なら貼り付け可能です。 (PON) ---- 画像として取り込む方法は、(PON)さんのコメント、私のコメントなど、いくつか方法があるけど 「遊び」で、私のコメントの2.を。 カラッポのユーザーフォームを用意して、そのユーザーフォームモジュールに以下を。 このフォームがモードレス表示されていて、ユーザーフォーム表示中にカレンダー領域の内容が変更された場合に その変更の状態を再度取り込む必要があれば、ユーザーフォームの「セル枠以外のところ」をクリック。 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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/201203/20120310233201.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97034 documents and 608188 words.
訪問者：