|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
借用罗老师的代码
Sub 建立图片目录()
Dim st As String
Dim file() As String, n As Integer, path As String, fd, T As String, PathStr As String, str As String, cell As Range
On Error GoTo err
Sheets(" ").Select '新建工作表
Sheets.Add
Range("A1").Select '选定单元格
With Application '引用应用程序
'如果选择的对象不是单元格，则提示并退出程序
If TypeName(Selection) <> "Range" Then MsgBox "请选择单元格" & Chr(10) & "将从您选择的单元格开始建立目录", 64, "提示": Exit Sub
Set fd = .FileDialog(msoFileDialogFolderPicker) '创建一个"浏览"对话框
If fd.Show = -1 Then T = fd.SelectedItems(1) Else Exit Sub '如果选择了文件夹，那么记录它的路径，否则退出程序
PathStr = IIf(Right(T, Len(T)) = "\", "", "\") '如果最后一位不是"\"则添加一位"\"
str = Dir(T & PathStr & "*.jpg") '获取JPG图片文件
While Len(str) > 0 '如果文件名长度大于0
n = n + 1 '累加变量
ReDim Preserve file(1 To n) '重新指定数组范围
file(n) = Left(str, Len(str) - 4) '将文件名写入数组中（去除右边四位，即后缀名）
str = Dir()
Wend
Selection(1, 1).Resize(n, 1) = WorksheetFunction.Transpose(file) '将数组写入选择的单元格，并向下纵向排列
Selection(1, 1).Resize(n, 1).Select '选择区域
If MsgBox("要导入图片吗？", vbYesNo, "导入图片") = vbYes Then '如果选择"是"
On Error Resume Next
i = .ActiveCell.RowHeight '记录当前行高
'让用户选择图片高度
j = .InputBox("请输入你希望照片显示的高度(10-200之间)," & Chr(10) & "当前单元格高度为" & i & "，请根据需要按比例输入新高度。" & Chr(10) & "百宝箱将按图片的高与宽相应地调整单元格行高与列宽。", "【确认照片高度】", 40, , , , , 1)
.ScreenUpdating = False '并闭屏幕更新
If j < 10 Then j = 10 '如果录入的值小于10，则按10处理，因为图片不适合太小
If j > 200 Then j = 200 '如果大于200则按200处理
For Each cell In Selection '遍历所有单元格
If cell = "" Then GoTo A '如果单元格空白则执行标签"A"之后的代码
myPath = T & "\" & cell.Text & ".jpg" '指定文件名（带通配符）
MyFile = Dir(myPath) '获取文件名
Do
ActiveSheet.Pictures.Insert(T & "\" & MyFile).Select '插入图片
If err.Number = 1004 Then GoTo A '如果有错误则执行下标签"A"后面的代码
With Selection.ShapeRange '引用插入的图片
.Top = cell.Offset(0, 1).Top + 2 '图片的上边距比单元格小2
.Left = cell.Offset(0, 1).Left + 2 '图片的左边距也比单元格小2，目的是防止图片压住单元格边框
.Height = j '设置图片高度
PicWidth = .Width '记录图片宽度
NewWidth = Round(Round(PicWidth / 0.75 - IIf(PicWidth > 9, 5, 0), 0) / IIf(PicWidth > 9, 8, 13), 2) ' 将图片宽度转换成列宽需要的值
If NewWidth > MaxWidth Then cell.Offset(0, 1).ColumnWidth = NewWidth + 0.8 '设置单元格列宽
If NewWidth > MaxWidth Then MaxWidth = NewWidth
cell.RowHeight = .Height + 4 '设置单元格行高
End With
MyFile = Dir
Loop Until MyFile = ""
A:
err.Clear '清除错误
Next cell
End If
err:
If err <> 0 Then MsgBox "您指定的文件夹下没有" & "*.jpg" & "图片文件!" '如果有错误,那么提示没有文件
End With
Columns("A:B").Select '把图片排序
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
End Sub
Sub 让图片适应单元格()
Dim sh As Shape '声明图形对象变量
For Each sh In ActiveSheet.Shapes '遍历本表所有图形对象
sh.LockAspectRatio = False '让图片可以高度、宽度分别调整，即不锁定长宽比
sh.Left = sh.TopLeftCell.Left '调整左边距
sh.Top = sh.TopLeftCell.Top '调整上边距
sh.Width = sh.TopLeftCell.Width '调整宽度
sh.Height = sh.TopLeftCell.Height '调整高度
Next sh
End Sub
Sub 让单元格适应图片()
Dim i As Integer, ShWidth, NewWidth, ShHeight, MaxWidth
Application.ScreenUpdating = False '关闭屏幕更新
With ActiveSheet '引用工作表
For i = 1 To .Shapes.Count '遍历所有图形对象
.Shapes(i).Left = .Shapes(i).TopLeftCell.Left '统一左边距
.Shapes(i).Top = .Shapes(i).TopLeftCell.Top '统一上边距
.Shapes(i).TopLeftCell.RowHeight = .Shapes(i).Height '统一高度
'调整宽度，不是统一，而要以宽度最大的图片为标准，从而使所有图片都容纳进单元格中
ShWidth = .Shapes(i).Width '记录图片的宽度
'将图片的宽度换算成可用于列宽的宽度（因为两个单位完全不同）
NewWidth = Round(Round(ShWidth / 0.75 - IIf(ShWidth > 9, 5, 0), 0) / IIf(ShWidth > 9, 8, 13), 2) ' 字符，最适合的列宽
If MaxWidth < ShWidth Then '如果图片在宽度大于变量MaxWidth
.Shapes(i).TopLeftCell.ColumnWidth = NewWidth '以换算后的宽度为标准设置单元格的宽度
MaxWidth = ShWidth '将图片的宽度赋予变量MaxWidth
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2012-5-25 10:31
楼主
