如何手动选择插入值/图片的位置

时间:2015-09-30 13:50:57

标签: excel vba excel-vba

我正在寻找的是在VBA宏中的一种方式,有一个设置,所以我的单元格被激活(在工作表中的任何地方),宏将插入特定的值或图片。

这样做有什么办法吗?

我只知道如何在宏中指定图片应插入的位置,但我希望将其插入我手动通过鼠标选择的位置。我的VBA代码:

Sub Importera_bilder()
    Dim mainWorkBook As Workbook
    Dim sh As Worksheet
    Dim ws2 As Worksheet
    Dim ws As Worksheet
    Dim sh2 As Worksheet

    Set sh = Sheets("Kundinformation")
    Set ws2 = Sheets("Partner_information")
    Set ws = Sheets("Kalkyl")
    Set sh2 = Sheets("Start")


    Set mainWorkBook = ActiveWorkbook
    Sheets("Projektunderlag").Activate
    FolderPath = ws2.Range("B21").Value
    Set fso = CreateObject("Scripting.FileSystemObject")
    NoOfFiles = fso.GetFolder(FolderPath).Files.Count
    Set listfiles = fso.GetFolder(FolderPath).Files
    For Each fls In listfiles
       strCompFilePath = FolderPath & "\" & Trim(fls.Name)
        If strCompFilePath <> "" Then
            If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _
            Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then
                 counter = counter + 1
                  'Sheets("Object").Range("A" & counter).Value = fls.Name
                  'Sheets("Projektunderlag").Range("M" & counter).ColumnWidth = 10
                'Sheets("Projektunderlag").Range("M" & counter).RowHeight = 13
                'Sheets("Projektunderlag").Range("M" & counter).Activate
                Call insert(strCompFilePath, counter)
                Sheets("Projektunderlag").Activate
            End If
        End If
    Next
mainWorkBook.Save
End Sub

Function insert(PicPath, counter)
'MsgBox PicPath
    With ActiveSheet.Pictures.insert(PicPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 270
            .Height = 230
        End With
         ActiveSheet.Range("M269").Select
        .Left = ActiveSheet.Range("M269").Left
        .Top = ActiveSheet.Range("M269").Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

2 个答案:

答案 0 :(得分:1)

您想使用ActiveCell属性。

例如,如果我想将数字900放在我选择的单元格中,那么我的VBA就是:

Sub Insert900()
    ActiveCell.Value = 900
End Sub

答案 1 :(得分:0)

Sub Importera_bilder()包含/更改

....
Dim PicNail as Range        ' this is where we nail the pic to
Set PicNail = Selection     ' current cell cusrsor position
....
Call insert(strCompFilePath, counter, PicNail)

并且插入函数变为......

Function insert(PicPath, counter, NailTo As Range)
'MsgBox PicPath
    With ActiveSheet.Pictures.Insert(PicPath)

        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = 270
            .Height = 230                  ' don't do both!
        End With
        .Left = NailTo.Left
        .Top = NailTo.Top
        .Placement = 1
        .PrintObject = True
    End With
End Function

<强> 注意:

当你锁定了AspectRatio时,没有必要改变宽度和高度,因为当你设置另一个时,任何一个都会自动调整(这是宽高比的意义)

如果要将图像调整到270W x 230H框中,则需要设置较大的尺寸(以较大者为准)并保留纵横比。

进一步阅读:

VBA Excel 2010 - Embedding Pictures and Resizing

OLEObject Height and Width are not consistent

另请注意,Excel 2010中的Picture.Insert方法与之前的行为有所不同...它是insertin ga LINKED对象,因此您可能希望包含对LinkToFileSaveWithDocument的分配或将代码更改为ActiveSheet.Shapes.AddPicture(...)