Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6729 / 13646 ツリー ←次へ | 前へ→

【43474】結合セルの中心にビットマップを貼り付ける pinkboo 06/10/16(月) 22:57 質問[未読]
【43491】Re:結合セルの中心にビットマップを貼り付ける Jaka 06/10/17(火) 13:48 発言[未読]
【43506】Re:結合セルの中心にビットマップを貼り付ける pinkboo 06/10/17(火) 21:50 お礼[未読]
【43492】Re:結合セルの中心にビットマップを貼り付ける Kein 06/10/17(火) 14:56 回答[未読]
【43493】Re:結合セルの中心にビットマップを貼り付ける Kein 06/10/17(火) 14:57 発言[未読]
【43507】Re:結合セルの中心にビットマップを貼り付ける pinkboo 06/10/17(火) 21:51 お礼[未読]

【43474】結合セルの中心にビットマップを貼り付ける
質問  pinkboo  - 06/10/16(月) 22:57 -

引用なし
パスワード
   初めて投稿します。VBAの初心者です。
特定の形のシート(テンプレート?)の結合されたセルに30種類以上あるビットマップの図を選択して、貼り付けようと思うのですがどうすればいいか、わかりません。
ビットマップの図は、どこにあればいいのでしょうか?
貼り付けるシートは、4種類あってそれぞれ8箇所、10箇所、12箇所、16箇所、それぞれ違う図を貼り付けなければなりません。
4種類のシートは貼り付け作業前に決まっていますが、貼り付ける結合セルの大きさは、それぞれで違います。この場合ビットマップの大きさもそれぞれで違うものがいるのでしょうか?よろしくお願いします。

【43491】Re:結合セルの中心にビットマップを貼り付ける
発言  Jaka  - 06/10/17(火) 13:48 -

引用なし
パスワード
   シートに貼り付けた元となる全ての画像にコピーをマクロ登録。
Sub コピー()
  ActiveSheet.Shapes(Application.Caller).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
End Sub

貼り付け先のセルを選択して実行。
Sub 貼り付け()
  For i = 1 To Selection.Cells.Columns.Count
   Wid = Wid + Selection.Cells(i).Width
  Next
  For i = 1 To Selection.Cells.Rows.Count
   Hei = Hei + Selection.Cells(i).Height
  Next
  AD = Selection.Cells(1).Address
  Application.ScreenUpdating = False
  Range(AD).PasteSpecial
  Selection.Width = Wid
  Selection.Height = Hei
  Range(AD).Select
  Application.ScreenUpdating = True
End Sub

尚、クリップボードの内容の違い、操作ミス、その他のエラー処理は全く入ってないから、後は自分で考えてください。

【43492】Re:結合セルの中心にビットマップを貼り付ける
回答  Kein  - 06/10/17(火) 14:56 -

引用なし
パスワード
   ThisWorkbookモジュールに、以下のコードを入れて定数 Fol の値を変更する。

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, _
ByVal Target As Range, Cancel As Boolean)
  Dim Lp As Single, Tp As Single
  Dim Wp As Single, Hp As Single
  Dim Pic As Object
  Dim MyF As String
  Const Fol As String = _
  "C:\Documents and Settings\User\My Documents\My Pictures"
  '↑実際に画像ファイルを保存しているフォルダーのパスに変更
   
  With ActiveCell
   If .MergeCells = False Then Exit Sub
   With .MergeArea
     Lp = .Left + 0.5: Tp = .Top + 0.5
     Wp = .Width - 1: Hp = .Height - 1
   End With
  End With
  ChDir
  With Application
   MyF = .GetOpenFilename("画像ファイル(*.bmp),*.bmp")
   If MyF = "False" Then GoTo ELine
   .ScreenUpdating = False
  End With
  Cancel = True
  With Sh.Pictures.Insert(MyF)
   .Left = Lp: .Top = Tp
   .Width = Wp: .Height = Hp
   .OnAction = "Del_Pic"
  End With
ELine:
  If Sh.ProtectDrawingObjects = False Then
   Sh.Protect , True, False, False
  End If
  With Application
   ChDir .DefaultFilePath
   .ScreenUpdating = True
  End With
End Sub

標準モジュールに以下のマクロを入れる。

Sub Del_Pic()
  Dim x As Variant
 
  x = Application.Caller
  If VarType(x) <> 8 Then Exit Sub
  If MsgBox("この画像を削除しますか ?", vbYesNo) = vbYes Then
   With ActiveSheet
     .Unprotect
     .Pictures(x).Delete
     .Protect , True, False, False
   End With
  End If
End Sub

そして任意の結合セルをダブルクリックすると、画像ファイルの保存先をカレント
フォルダーとして、ファイルを開くダイアログが出ます。そこから任意のファイル
を選んで OK するだけです。
挿入した画像は、シングルクリックすると削除を問い合わせるメッセージが出ます。

【43493】Re:結合セルの中心にビットマップを貼り付ける
発言  Kein  - 06/10/17(火) 14:57 -

引用なし
パスワード
   > ChDir


ChDir Fol

と、修正して下さい。

【43506】Re:結合セルの中心にビットマップを貼り付ける
お礼  pinkboo  - 06/10/17(火) 21:50 -

引用なし
パスワード
   ▼Jaka さん:
>シートに貼り付けた元となる全ての画像にコピーをマクロ登録。
>Sub コピー()
>  ActiveSheet.Shapes(Application.Caller).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
>End Sub
>
>貼り付け先のセルを選択して実行。
>Sub 貼り付け()
>  For i = 1 To Selection.Cells.Columns.Count
>   Wid = Wid + Selection.Cells(i).Width
>  Next
>  For i = 1 To Selection.Cells.Rows.Count
>   Hei = Hei + Selection.Cells(i).Height
>  Next
>  AD = Selection.Cells(1).Address
>  Application.ScreenUpdating = False
>  Range(AD).PasteSpecial
>  Selection.Width = Wid
>  Selection.Height = Hei
>  Range(AD).Select
>  Application.ScreenUpdating = True
>End Sub
>
>尚、クリップボードの内容の違い、操作ミス、その他のエラー処理は全く入ってないから、後は自分で考えてください。
早速のお返事ありがとうございました。
明日、会社にて試してみたいと思います。
また、わからないところがありましたら、ヨロシクご指導願います。

【43507】Re:結合セルの中心にビットマップを貼り付ける
お礼  pinkboo  - 06/10/17(火) 21:51 -

引用なし
パスワード
   ▼Kein さん:
>> ChDir
>↓
>
> ChDir Fol
>
>と、修正して下さい。
早速のお返事ありがとうございました。
明日、会社にて試してみたいと思います。
また、わからないところがありましたら、ヨロシクご指導願います。

6729 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free