使用宏插入图片如何固定图片大小

蓝桥玄霜

没有附件不能调试代码。

840205910

蓝桥玄霜 发表于 2012-10-30 14:26
没有附件不能调试代码。

蓝版老师：请帮忙看看http://club.excelhome.net/thread-937484-1-1.html  谢谢！

herrowbh

蓝桥玄霜 发表于 2012-10-30 14:26
没有附件不能调试代码。

汇e总.zip (52.17 KB, 下载次数: 157)

2012-10-30 15:17 上传

点击文件名下载附件

加了附件，附上照片。谢谢！

herrowbh

附上了附件，请各位大虾帮助我啊{:soso_e101:}

蓝桥玄霜

1. Sub 插入图片()
   
2. On Error Resume Next '设置错误处理
   
3. Application.ScreenUpdating = False '关闭屏幕刷新
   
4. Dim rngTemp As Range, k As Range, picPath$, picTemp As Picture
   
5. '设定图片名称所在单元格区域
   
6. Set rngTemp = Application.InputBox("选择图片名称所在单元格区域：", "选择单元格", Type:=8)
   
7. For Each k In rngTemp '循环插入图片
   
8. k.Offset(0, 1).Select '选择插入图片的位置
   
9. picPath = ThisWorkbook.Path & "" & Trim(k) & ".jpg" '定义插入图片的地址
   
10. Set picTemp = ActiveSheet.Pictures.Insert(picPath) '插入图片
    
11. picTemp.Name = k  '设定所插入图片的名称
    
12. picTemp.Placement = xlMoveAndSize '设置图片可以随单元格的变动而改变大小和位置
    
13. 
    
14. With picTemp.Select
    
15.        Selection.ShapeRange.LockAspectRatio = 0
    
16.        Selection.ShapeRange.Width = k.Offset(0, 1).Width * 0.85
    
17.        Selection.ShapeRange.Height = k.Offset(0, 1).Height * 0.85
    
18.        ta = .Range("b1").Height + .Range("b2").Height     ' 2单元格高度
    
19.        tb = .Range("b1").Width * 3 + .Range("a1").Width * 2 ' 3单元格宽度
    
20.         tc = .Shapes(1).Height               '图片高度
    
21.         td = .Shapes(1).Width                '图片宽度
    
22.         tm = Application.WorksheetFunction.Min(ta / tc, tb / td)    '单元与图片之间长宽差异比例的最小值
    
23.         .Shapes(1).Height = tc * tm    '按比例调整图片宽度
    
24.         .Shapes(1).Width = td * tm      '按比例调整图片高度
    
25.         .Shapes(1).Top = .Range("a1").Top + (ta - .Shapes(1).Height) / 2 '垂直居中:
    
26.         .Shapes(1).Left = .Range("a1").Left + (tb - .Shapes(1).Width) / 2  '水平居中:
    
27. 
    
28. 
    
29. End With
    
30. Set picTemp = Nothing '重置图片对象
    
31. Next
    
32. [a1].Select
    
33. Application.ScreenUpdating = True '打开屏幕刷新
    
34.   
    
35.   End Sub
    
36. 
    

复制代码

蓝桥玄霜

请见附件。

jxlhx97601

标签生成器.rar (10.25 KB, 下载次数: 72)

2012-11-1 12:26 上传

点击文件名下载附件

搭班车,各位大侠好，小女子急用,请帮我制作一个应用VBA的标签生成器，要求请见附件中的说明。谢谢了！在线急盼！！！！

dragonthree

要花费点时间！

蓝桥玄霜

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Count > 1 Then Exit Sub
   
3. If Target = "" Then Exit Sub
   
4. If Target.Address <> "$C$2" Then Exit Sub
   
5. Dim i&, Myr&, y&, ye%, j&, aa, Arr, d, rng As Range, n%, c%, m%, mm%, nn%, xx$
   
6. Set d = CreateObject("Scripting.Dictionary")
   
7. Set rng = Sheet3.[q1:r4]
   
8. xx = [b2].Value
   
9. Myr = Sheet1.[a65536].End(xlUp).Row
   
10. Arr = Sheet1.Range("a1:d" & Myr)
    
11. For i = 2 To UBound(Arr)
    
12.     If Arr(i, 4) <> "" Then d(Arr(i, 4)) = d(Arr(i, 4)) & i & ","
    
13. Next
    
14. t = d(Target.Value)
    
15. If t = "" Then MsgBox "没有这个班级的数据！": Exit Sub
    
16. t = Left(t, Len(t) - 1)
    
17. If InStr(t, ",") Then
    
18.     aa = Split(t, ",")
    
19.     y = (UBound(aa) + 1) Mod 12
    
20.     If y = 0 Then
    
21.         ye = Int((UBound(aa) + 1) / 12)
    
22.     Else
    
23.         ye = Int((UBound(aa) + 1) / 12) + 1
    
24.     End If
    
25.     For j = 1 To ye
    
26.         Sheet3.[a1:l15].ClearContents
    
27.         Sheet3.[a1:l15].Borders.LineStyle = xlNone
    
28.         Do
    
29.         n = n + 1: nn = nn + 1
    
30.         c = n Mod 4: mm = Int(n / 4)
    
31.         If c <> 0 Then
    
32.             col = 3 * c - 1
    
33.             m = 5 * mm + 1
    
34.         If m > 11 Then n = 0: nn = nn - 1: Exit Do
    
35.         Else
    
36.             col = 11
    
37.         End If
    
38.         rng.Copy Sheet3.Cells(m, col)
    
39.         With Sheet3
    
40.             .Cells(m, col).Value = xx
    
41.             .Cells(m + 1, col + 1).Value = Arr(aa(nn - 1), 4)
    
42.             .Cells(m + 2, col + 1).Value = Arr(aa(nn - 1), 2)
    
43.             .Cells(m + 3, col + 1).Value = Arr(aa(nn - 1), 1)
    
44.         End With
    
45.         Loop While nn < UBound(aa) + 1
    
46.         Sheet3.[a1:l15].PrintOut
    
47.     Next
    
48. End If
    
49. End Sub
    

复制代码