《Excel 批量插入图片 VBA代码》由会员分享，可在线阅读，更多相关《Excel 批量插入图片 VBA代码（6页珍藏版）》请在金锄头文库上搜索。
1、Excel 批量插入图片 VBA 代码(2011-06-24 08:56:26)转载标签： excel 批量插入图片代码杂谈 在要插入图片的文件夹里新建一个 Excel 文件，打开这个 Excel 文件，在要插入图片的单元格里填上图片文件名（不要扩展名） ，选中要插入图片的单元格，修改单元格的大小以显示所需要的图片大小，运行宏代码。1、Alt+F11 调取 VBA 编辑窗口，查看代码，将以下代码全部复制进去；2、关闭 VBA 窗口，Excel-视图-宏- 查看宏；3、Book1.xls!Sheet1.insertPic ，选中所要插入图片的单元格，执行；4、图片自动插入对应的单元格中。 （图片
2、尺寸均可通过单元格大小进行调解，边框可设置）代码如下：Sub insertPic() 宏由 万加美酒编写，时间: 2009-6-1 Dir 函数批量获取指定目录下所有文件名和内容On Error Resume NextApplication.ScreenUpdating = False 关闭屏幕更新Dim MR As RangeFor Each MR In SelectionIf Not IsEmpty(MR) And Dir(ActiveWorkbook.Path & & MR.Value & .jpg) ThenMR.SelectML = MR.LeftMT = MR.TopMW = M
3、R.WidthMH = MR.HeightActiveSheet.Shapes.AddShape(msoShapeRectangle, ML, MT, MW, MH).SelectSelection.ShapeRange.Fill.UserPicture _ActiveWorkbook.Path & & MR.Value & .jpg 当前文件所在目录下以当前单元内容为名称的.jpg 图片End IfNextSet MR = NothingApplication.ScreenUpdating = True 开启屏幕更新End Sub我想 按一下按钮，插入图片 我的 vba code 如下: S
4、ub Picture_Click_06202010()x = Cells (8, 4).ValueChDir C:UsersmynameDesktoppictureActiveSheet.Pictures.Insert x + .jpgEnd Sub* cells (8, 4) 的 值是图片的名称 我的 vba code 有错. ActiveSheet.Pictures.Insert(C:UsersmynameDesktoppicture & x & .jpg)插入档案时请用全路径，不要用 ChDir 变更工作路径，因为 ChDir 无法处理变更工作磁盘。Excel,遗忘密码后如何撤销工作表保
5、护密码1、打开您需要撤销保护密码的 Excel 文件；2、依次点击菜单栏上的工具-宏- 录制新宏，输入宏名字如:ab ；3、停止录制(这样得到一个空宏 )；4、依次点击菜单栏上的工具-宏- 宏,选 ab,点编辑按钮；5、删除窗口中的所有字符(只有几个 ),替换为以下内容；Public Sub 工作表保护密码 ()Const DBLSPACE As String = vbNewLine & vbNewLineConst AUTHORS As String = DBLSPACE & vbNewLine & _作者:ericConst HEADER As String = 工作表保护密码Const
6、VERSION As String = DBLSPACE & 版本 Version 1.1.1Const REPBACK As String = DBLSPACE & Const ZHENGLI As String = DBLSPACE & ericConst ALLCLEAR As String = DBLSPACE & 该工作簿中的工作表密码保护已全部解除。 & DBLSPACE & 请记得重新设置密码 _& DBLSPACE & 注意：此方法仅用于遗忘密码使用。 Const MSGNOPWORDS1 As String = 该文件工作表中没有加密Const MSGNOPWORDS2 As
7、 String = 该文件工作表中没有加密 2Const MSGTAKETIME As String = 请耐心等候! & DBLSPACE & 按确定开始回复Const MSGPWORDFOUND1 As String = 密码重新组合为: & DBLSPACE & $ & DBLSPACE & _如果该文件工作表有不同密码,将搜索下一组密码并修改清除Const MSGPWORDFOUND2 As String = 密码重新组合为: & DBLSPACE & $ & DBLSPACE & _如果该文件工作表有不同密码,将搜索下一组密码并解除Const MSGONLYONE As String
8、 = 确保为唯一的?Dim w1 As Worksheet, w2 As WorksheetDim i As Integer, j As Integer, k As Integer, l As IntegerDim m As Integer, n As Integer, i1 As Integer, i2 As IntegerDim i3 As Integer, i4 As Integer, i5 As Integer, i6 As IntegerDim PWord1 As StringDim ShTag As Boolean, WinTag As BooleanApplication.Scr
9、eenUpdating = FalseWith ActiveWorkbookWinTag = .ProtectStructure Or .ProtectWindowsEnd WithShTag = FalseFor Each w1 In WorksheetsShTag = ShTag Or w1.ProtectContentsNext w1If Not ShTag And Not WinTag ThenMsgBox MSGNOPWORDS1, vbInformation, HEADERExit SubEnd IfMsgBox MSGTAKETIME, vbInformation, HEADER
10、If Not WinTag ThenElseOn Error Resume NextDo dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126With ActiveWorkbook.Unprote
11、ct Chr(i) & Chr(j) & Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & _Chr(i3) & Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If .ProtectStructure = False And _.ProtectWindows = False ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)
12、MsgBox Application.Substitute(MSGPWORDFOUND1, _$, PWord1), vbInformation, HEADERExit Do Bypass all for.nextsEnd IfEnd WithNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfIf WinTag And Not ShTag ThenMsgBox MSGONLYONE, vbInformation, HEADERExit S
13、ubEnd IfOn Error Resume NextFor Each w1 In WorksheetsAttempt clearance with PWord1w1.Unprotect PWord1Next w1On Error GoTo 0ShTag = FalseFor Each w1 In WorksheetsChecks for all clear ShTag triggered to 1 if not.ShTag = ShTag Or w1.ProtectContentsNext w1If ShTag ThenFor Each w1 In WorksheetsWith w1If
14、.ProtectContents ThenOn Error Resume NextDo Dummy do loopFor i = 65 To 66: For j = 65 To 66: For k = 65 To 66For l = 65 To 66: For m = 65 To 66: For i1 = 65 To 66For i2 = 65 To 66: For i3 = 65 To 66: For i4 = 65 To 66For i5 = 65 To 66: For i6 = 65 To 66: For n = 32 To 126.Unprotect Chr(i) & Chr(j) &
15、 Chr(k) & _Chr(l) & Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)If Not .ProtectContents ThenPWord1 = Chr(i) & Chr(j) & Chr(k) & Chr(l) & _Chr(m) & Chr(i1) & Chr(i2) & Chr(i3) & _Chr(i4) & Chr(i5) & Chr(i6) & Chr(n)MsgBox Application.Substitute(MSGPWORDFOUND2, _$, PWor
16、d1), vbInformation, HEADERleverage finding Pword by trying on other sheetsFor Each w2 In Worksheetsw2.Unprotect PWord1Next w2Exit Do Bypass all for.nextsEnd IfNext: Next: Next: Next: Next: NextNext: Next: Next: Next: Next: NextLoop Until TrueOn Error GoTo 0End IfEnd WithNext w1End IfMsgBox ALLCLEAR & AUTHORS & VERSI
