Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2336 / 76807

←次へ　｜　前へ→


	【80115】フルパスの受け渡し

Image - 18/8/17(金) 19:39 -


	引用なし

	パスワード

フォーム上のイメージコントロールに画像を表示し、
その画像で良ければ、OKボタンを押してセルに張付けたい。

下記のコードで、画像ファイルのフルパスをセルに書き出さずに
フルパスを受け取りたいのですが、どのように直せば良いか教えて下さい。

以下、コード。

画像をファイルから選択し、Image1に表示。----------------------------------------------------
Sub CommandButton1_Click

　Dim FileType As String
　Dim Dialog As String
　Dim Filename As Variant

　FileType = "画像ﾌｧｲﾙ (*.jpg;*.gif;*.png),*.jpg;*.gif;*.png," _
　　　　　 & "JPEG 形式 (*.jpg),*.jpg," _
　　　　　 & "GIF 形式 (*.gif),*.gif," _
　　　　　 & "PNG 形式 (*.png),*.png"

　Dialog = "画像ファイルの選択"
　Filename = Application.GetOpenFilename(FileType, , Dialog)

　If Filename <> False Then
　　Image1.Picture = LoadPicture(Filename)
　Else
　　Image1.Picture = LoadPicture("")
　End If

End Sub

Image1の画像で良ければ、セルに貼付け。------------------------------------------------------

CommandButton2_Click

　Dim Filename As Variant
　Dim Shape As Variant
　Dim MovCell As Range
　Dim MovLeft As Double
　Dim MovTop As Double
　Dim MovHeight As Double
　Dim MovWidth As Double

　If Filename <> False Then
　　For Each Shape In Worksheets("Sheet1").DrawingObjects
　　　If Not Intersect(Shape.TopLeftCell, Worksheets("Sheet1"). _
　　　　　　　　　　　 Range("F10:I21")) Is Nothing Then
　　　　Shape.Delete
　　　End If
　　Next

　　Worksheets("Sheet1").Range("F10:I21").Value = Dir(Filename)
　　
　　With Worksheets("Sheet1").Range("F10:I21")
　　　MovLeft = .Left
　　　MovTop = .Top
　　　MovHeight = .Cells(.Count).Offset(1).Top - .Top
　　　MovWidth = .Cells(.Count).Offset(, 1).Left - .Left
　　End With

　　With Worksheets("Sheet1").Shapes.AddPicture(Filename:=Filename, LinkToFile:=False, _
　　　　　　　　　　　　　　　　　　　　　　　　SaveWithDocument:=True, Left:=Selection.Left, _
　　　　　　　　　　　　　　　　　　　　　　　　Top:=Selection.Top, Width:=0, Height:=0)
　　End With

　　With Worksheets("Sheet1").Pictures(Worksheets("Sheet1").Pictures.Count).ShapeRange
　　　.LockAspectRatio = msoFalse
　　　.Parent.Visible = msoTrue
　　　.Left = MovLeft
　　　.Top = MovTop
　　　.Height = MovHeight
　　　.Width = MovWidth
　　　.Line.Visible = msoTrue
　　　.Line.Style = msoLineSingle
　　　.Line.ForeColor.RGB = RGB(0, 0, 0)
　　　.Line.Weight = 1.5
　　　.Name = Dir(Filename)
　　End With

　Else
　　For Each Shape In Worksheets("Sheet1").DrawingObjects
　　　If Not Intersect(Shape.TopLeftCell, Worksheets("Sheet1"). _
　　　　　　　　　　　 Range("F10:I21")) Is Nothing Then
　　　　End
　　　End If
　　Next

　　Worksheets("Sheet1").Range("F10:I21").Value = "ファイルが選択されていません。"

　End If

0 hits

▼

【80115】フルパスの受け渡し Image 18/8/17(金) 19:39