Excel VBA質問箱 IV

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

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


48 / 74519 ←次へ | 前へ→

【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

66 hits

【80115】フルパスの受け渡し Image 18/8/17(金) 19:39 質問[未読]
【80116】Re:フルパスの受け渡し マナ 18/8/17(金) 21:18 発言[未読]
【80117】Re:フルパスの受け渡し Image 18/8/17(金) 23:07 発言[未読]
【80118】Re:フルパスの受け渡し マナ 18/8/18(土) 8:55 発言[未読]

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