Excel VBA質問箱 IV

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

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


38378 / 76732 ←次へ | 前へ→

【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 するだけです。
挿入した画像は、シングルクリックすると削除を問い合わせるメッセージが出ます。

1 hits

【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 お礼

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