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