开发工具:
文件大小: 38kb
下载次数: 0
上传时间: 2011-10-28
详细说明： 批量照片自动插入不再是难题，一键全插入VBA代码如下： Option Explicit Sub InsertPicture() Dim MyShape As Shape Dim r As Integer Dim c As Integer Dim PicPath As String Dim Picrng As Range With Sheet1 For Each MyShape In .Shapes If MyShape.Type = 13 Then MyShape.Delete End If Next For r = 7 To .Cells(.Rows.Count, 7).End(xlUp).Row Step 10 For c = 6 To 6 PicPath = ThisWorkbook.Path & "\" & .Cells(r, c).Text & ".jpg&qu ot; If Dir(PicPath) <> "" Then Set MyShape = .Shapes.AddPicture(PicPath, False, True, 250, 250, 250, 250) Set Picrng = .Range(Cells(r - 4, c - 4), Cells(r + 1, c - 4)) With MyShape .LockAspectRatio = msoFalse .Top = Picrng.Top + 1.5 .Left = Picrng.Left + 1.5 .Width = Picrng.Width - 1.5 .Height = Picrng.Height - 1.5 .TopLeftCell = "" End With Else .Cells(r - 4, c - 4) = "暂无照片" End If Next Next End With Set MyShape = Nothing Set Picrng = Nothing End Sub Sub MyName() Dim MyName As String Dim r As Integer r = 7 MyName = Dir(ThisWorkbook.Path & "\" & "*.jpg") Do While MyName <> "" If MyName <> ".jpg" And MyName <> ".." Then Cells(r, 6) = MyName r = r + 10 Else Cells(r, 6).ClearContents End If MyName = Dir Loop Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _ :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False End Sub ...展开收缩
(系统自动生成,下载前可以参看下载内容)
下载文件列表
相关说明
- 本站资源为会员上传分享交流与学习,如有侵犯您的权益,请联系我们删除.
- 本站是交换下载平台，提供交流渠道，下载内容来自于网络，除下载问题外，其它问题请自行百度。
- 本站已设置防盗链，请勿用迅雷、QQ旋风等多线程下载软件下载资源，下载后用WinRAR最新版进行解压.
- 如果您发现内容无法下载，请稍后再次尝试；或者到消费记录里找到下载记录反馈给我们.
- 下载后发现下载的内容跟说明不相乎，请到消费记录里找到下载记录反馈给我们，经确认后退回积分.
- 如下载前有疑问，可以通过点击"提供者"的名字，查看对方的联系方式，联系对方咨询.
