点击显示图像的形状或按钮（预览/关闭） [英] click shape or button (preview/close) that displays an image

问题描述

我是VBA的新手，并寻求工作项目的帮助。我已经做了一些研究，开始了，但现在已经过头了。

我的目标是：
创建从计算机上另一个位置显示图像的点击形状或按钮（预览/关闭）。

显示的图像将取决于输入在同一行中的每个名称的数据输入（col A：jpeg图像的同一个名称）。

此外，我想要一个新的按钮/形状在相应的单元格中添加新名称时自动创建

感谢Rick

  Sub Macro1（）
 
 Dim Path As String 
 
 
设置myDocument =工作表（1）
 
 
 
 Path =F：\CAD_CAM division \Unsorted Models\
 
 myDocument.Pictures.Insert（Path& ActiveCell.Value&.jpg）
 
 
使用ActiveSheet.Shapes（Rounded Rect角度1）TextFrame2.TextRange.Characters 
 
如果.Text =关闭然后
 
 .Text =预览
 
 ActiveSheet。 Pictures.Delete 
 Else 
 
 .Text =关闭
 
使用ActiveSheet.Shapes（Rounded Rectangle 1）
 
 
 
结束
 
结束如果
 
结束
 End Sub 
  

解决方案

虽然您的原始代码实际工作，但我做了一些微小的调整，以确保所有（多个）图片包含/显示并将这些图片对齐在一起。看看代码中的注释，让我知道你的想法：

  Option Explicit 
 
 Sub Macro1（）
 
 Dim lngRow As Long 
 Dim strPath As String 
 Dim picItem As Picture 
 Dim shtPatient As Worksheet 
 
'如果有多张照片，那么它们之间应该显示
'。 dblLeft和dblTop将使用
'将下一张照片放在最后一张照片下。 
 Dim dblTop As Double 
 Dim dblLeft As Double 
 
 Set shtPatient = ThisWorkbook.Worksheets（1）
 strPath =F：\CAD_CAM division\Unsorted Models \
 
带有shtPatient.Shapes（Rounded Rectangle 1）。TextFrame2.TextRange.Characters 
如果.Text =Close然后
 .Text =预览 
 ActiveSheet.Pictures.Delete 
 Else 
 .Text =关闭
对于lngRow = 2到shtPatient.Cells（shtPatient.Rows.Count，A）。End xlUp）.Row 
'首先检查文件是否存在/可以被找到并插入
如果Dir（strPath& shtPatient.Cells（lngRow，1）.Value2&.jpg）< ;> 然后
 Set picItem = shtPatient.Pictures.Insert（strPath& shtPatient.Cells（lngRow，1）.Value2&.jpg）
'命名图片，以便后来找到再次使用VBA 
 picItem.Name = shtPatient.Cells（lngRow，1）.Value2& .jpg
如果lngRow = 2然后
 picItem.Top = shtPatient.Range（F2）。顶部
 picItem.Left = shtPatient.Range（F2）。左
 dblTop = picItem.Top + picItem.Height + 10 
 dblLeft = picItem.Left 
 Else 
 picItem.Top = dblTop 
 picItem.Left = dblLeft 
 dblTop = picItem.Top + picItem.Height + 10 
结束如果
结束如果
下一个lngRow 
结束如果
结束
 
结束Sub 
  

I am new to VBA and seeking help on a work project. I have done some research and got started but am now over my head.

My objectives are: Create a click shape or button (preview/close) that displays an image from another location on computer.

The image displayed will be dependent on the data input (col A: patient name; same name of jpeg image) for each name that is entered in the same row.

Also I would like a new button/shape to be automatically created in the corresponding cell when a new name is added

Thanks Rick

Sub Macro1()

Dim Path As String


Set myDocument = Worksheets(1)



Path = "F:\CAD_CAM division\Unsorted Models\"

 myDocument.Pictures.Insert (Path & ActiveCell.Value & ".jpg")


    With ActiveSheet.Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters

        If .Text = "Close" Then

            .Text = "Preview"

            ActiveSheet.Pictures.Delete
        Else

            .Text = "Close"

            With ActiveSheet.Shapes("Rounded Rectangle 1")



            End With

        End If

    End With
End Sub

解决方案

While your original code was actually working, I made a few slight adjustments to ensure that all (multiple) pictures are included / shown on the sheet and to align these picture below each other. Have a look at the comments in the code and let me know what you think:

Option Explicit

Sub Macro1()

Dim lngRow As Long
Dim strPath As String
Dim picItem As Picture
Dim shtPatient As Worksheet

'If there are multiple pictures then they should be shown
'  underneath each other. dblLeft and dblTop will be used
'  to place the next picture underneath the last one.
Dim dblTop As Double
Dim dblLeft As Double

Set shtPatient = ThisWorkbook.Worksheets(1)
strPath = "F:\CAD_CAM division\Unsorted Models\"

With shtPatient.Shapes("Rounded Rectangle 1").TextFrame2.TextRange.Characters
    If .Text = "Close" Then
        .Text = "Preview"
        ActiveSheet.Pictures.Delete
    Else
        .Text = "Close"
        For lngRow = 2 To shtPatient.Cells(shtPatient.Rows.Count, "A").End(xlUp).Row
            'First check if the file actually exists / can be found and inserted
            If Dir(strPath & shtPatient.Cells(lngRow, 1).Value2 & ".jpg") <> "" Then
                Set picItem = shtPatient.Pictures.Insert(strPath & shtPatient.Cells(lngRow, 1).Value2 & ".jpg")
                'Name the picture so it can be found afterwards again using VBA
                picItem.Name = shtPatient.Cells(lngRow, 1).Value2 & ".jpg"
                If lngRow = 2 Then
                    picItem.Top = shtPatient.Range("F2").Top
                    picItem.Left = shtPatient.Range("F2").Left
                    dblTop = picItem.Top + picItem.Height + 10
                    dblLeft = picItem.Left
                Else
                    picItem.Top = dblTop
                    picItem.Left = dblLeft
                    dblTop = picItem.Top + picItem.Height + 10
                End If
            End If
        Next lngRow
    End If
End With

End Sub

这篇关于点击显示图像的形状或按钮（预览/关闭）的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！