简体   繁体   English

如何使用VBA打开新工作簿并添加图像?

[英]How to open a new workbook and add images with VBA?

I'm trying to get a macro for Excel 2007to open a folder with a bunch of images in them. 我正在尝试获取Excel 2007的宏以打开其中包含一堆图像的文件夹。 Then Create a new workbook and embed the images into it. 然后创建一个新的工作簿并将图像嵌入其中。

Everything works if I comment out the line Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310 If I uncomment that line I get "Run-time error '434': Object required" 如果我注释掉Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310行,一切正常, Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310如果取消注释该行,则会收到“运行时错误'434':必需对象”

I've check that Sheet.Shapes is returning a Shapes object, it is but the Shapes object is empty. 我检查了Sheet.Shapes是否返回一个Shapes对象,但是Shapes对象为空。 When I try Sheet.Shapes,AddPicture on a workbook that is opened outside of the macro, it adds the images. 当我尝试在宏外部打开的工作簿上使用Sheet.Shapes,AddPicture时,它会添加图像。 I've also checked that Sheet.Shapes.AddShape works with the workbook opened in the macro, it does. 我还检查了Sheet.Shapes.AddShape是否可以在宏中打开的工作簿正常工作。

At this point, I'm at a lose for what the issue might be. 在这一点上,我对可能出现的问题不知所措。 Does anyone have any experience with this sort of thing? 有人对这种事情有经验吗? Should I be using a different method? 我应该使用其他方法吗? Thanks in advance for any help or guidance. 在此先感谢您的帮助或指导。

Sub Macro1()
Dim ImagePath, Flist
ImagePath = GetFolder()
If ImagePath = "" Then Exit Sub
Flist = FileList(ImagePath)
Name = "C:\target.xlsm"
Set Book = Workbooks.Add
Set Sheet = Book.Sheets(1)
For i = 1 To 5
    cell = "C" + CStr(i)
    F = ImagePath + "\" + Flist(i - 1)
        Sheet.Shapes.AddPicture FileName:=F, linktofile:=msoFalse, _
            savewithdocument:=msoCTrue, Left:=cell.Left + 5, Top:=cell.Top + 5, Width:=560, Height:=310
    Next
Book.SaveAs FileName:=Name, FileFormat:=52
Book.Close
End Sub

 Function FileList(ByVal fldr As String) As Variant
'Lists all the files in the current directory
'Found at http://www.ozgrid.com/forum/showthread.php?t=71409
    Dim sTemp As String, sHldr As String
    If Right$(fldr, 1) <> "\" Then fldr = fldr & "\"
    sTemp = Dir(fldr & "*.png")
    If sTemp = "" Then
        FileList = False
        Exit Function
    End If
    Do
        sHldr = Dir
        If sHldr = "" Then Exit Do
        sTemp = sTemp & "|" & sHldr
    Loop
    FileList = Split(sTemp, "|")
End Function

Function GetFolder() As String
Folder:
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .Title = "New Screenshot Folder"
    .Show
    num = .SelectedItems.Count
    If .SelectedItems.Count = 0 Then
        GetFolder = ""
    Else: GetFolder = .SelectedItems(1)
    End If
End With
End Function

You can't define a cell by creating the string "C1", that's just the address. 您无法通过创建字符串“ C1”来定义单元格,而这只是地址。 The way you did it, cell is a string and a string doesn't have any properties. 您的操作方式是, cell是一个字符串,并且字符串没有任何属性。 What you want is a range object so either use 您想要的是一个范围对象,因此可以使用

Dim cell As Range
Set cell = sheet.Range("C" & i)

or 要么

Dim cell As Range
Set cell = sheet.Cells(i, 3)

You should always Dim all variables, use Option Explicit on top of your module so you don't forget it ;) 您应该始终使所有变量Dim ,在模块顶部使用Option Explicit ,以免忘记它;)

This will often prevent mistakes. 这通常可以防止错误。 Of course you should Dim them with the correct type, ie Dim FilePath As String . 当然,应该在Dim正确类型,即他们Dim FilePath As String

The correct command would be: 正确的命令是:

        Sheet.Shapes.AddPicture Filename:=F, linktofile:=msoFalse, _
        savewithdocument:=msoCTrue, Left:=Range(cell).Left + 5, Top:=Range(cell).Top + 5, Width:=560, Height:=310

I strongly advise you to change your Name variable name, as it will cause errors on recent versions of excel. 我强烈建议您更改Name变量名称,因为这会在最新版本的excel中引起错误。

声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.

 
粤ICP备18138465号  © 2020-2024 STACKOOM.COM