word如何自动调整插入图片的大小？

zhanglei1371

各位好！
想问个问题，在向word中插入图片时，能否使用vba做到不论插入任何尺寸的图片，在插入后都自动调整为宽度为6，长度为5.5，因为有好多图片，每次都要手动调整大小，很费事...
如果可以的话，能否提供下vba代码，非常感谢！！！

gdqb521

干嘛要把word不擅长的任务交给它做啊。用图像软件批量处理后，插入应该更好。word vba应该可以，但是没必要吧。不好意思，我对vba不是太通透。

白月清风

Sub 插入图片()
Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFilePicker)
    With myfile
         .InitialFileName = "C:\"
            If .Show = -1 Then
            For Each fn In .SelectedItems   
          Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
           mypic.Width = 400 '根据需要设置，不知道楼主6、5.5用的什么单位
           mypic.Height = 300
     Next fn
          End If
    End With
    Set myfile = Nothing
End Sub

此代码可以实现选择一张或多张图片插入

zhanglei1371

白月清风 发表于 2012-11-10 19:58  Sub 插入图片()  Dim myfile As FileDialog  Set myfile = Application.FileDialog(msoFileDialogFileP ...

学习了，非常感谢！

♂守护＄天使♀

好好研究一下

俯视姚明

好好研究一下。

csnAlex

修改了一下“白月清风”的代码，可以随意指定宽度和高度。

1. Sub 插入图片()
   
2.     Dim myfile As FileDialog
   
3.     Dim myW As Single, myH As Single
   
4.    
   
5.     myW = InputBox("请输入图片宽度，单位：厘米", , 6)
   
6.     myH = InputBox("请输入图片高度，单位：厘米", , 5.5)
   
7.    
   
8.     Set myfile = Application.FileDialog(msoFileDialogFilePicker)
   
9.     With myfile
   
10.          .InitialFileName = "C:"
    
11.             If .Show = -1 Then
    
12.             For Each fn In .SelectedItems
    
13.           Set mypic = Selection.InlineShapes.AddPicture(FileName:=fn, SaveWithDocument:=True)
    
14.            mypic.Width = CentimetersToPoints(myW)
    
15.            mypic.Height = CentimetersToPoints(myH)
    
16.      Next fn
    
17.           End If
    
18.     End With
    
19.     Set myfile = Nothing
    
20. End Sub
    

复制代码

zhanglei1371

现在再来看这个本人初学vba时的问题，简直是简单的没法再简单了……

liuhoubin168

zhanglei1371 发表于 2015-1-7 15:51
现在再来看这个本人初学vba时的问题，简直是简单的没法再简单了……

祝贺你，VBA水平得到了大幅度提高！！

wzhfirst

白月清风 发表于 2012-11-10 19:58
Sub 插入图片()
Dim myfile As FileDialog
    Set myfile = Application.FileDialog(msoFileDialogFileP ...

帮忙看看我这个代码怎么用ActiveSheet.Shapes.AddPicture来写，谢谢

Private Sub CommandButton1_Click()
On Error Resume Next
Dim filefilter1, filennames As String
filefilter1 = ("所有图片文件 (*.jpg;*.bmp;*.png;*.gif),*.jpg;*.bmp;*.png;*.gif")
filennames = Application.GetOpenFilename(filefilter1, , "请选一个图片文件", , MultiSelect:=False)
With ActiveSheet.Pictures.Insert(filennames)

    .ShapeRange.LockAspectRatio = msoFalse

     .Left = ActiveCell.Left
    .Top = ActiveCell.Top

    .Width = Selection.Width

    .Height = Selection.Height
End With
End Sub