VBS脚本插入excel图片

--VBS脚本插入excel图片

-------------------------2013/11/23

根据第一列的值，需找对应的图片，然后插入的指定的列中，图片根据列的长宽信息决定图片大小。

代码1图片正常状态，不旋转

Dim fso
Wscript.StdOut.WriteLine "*********************************************** "
Wscript.StdOut.WriteLine "*       AUTO INSERT WIN BOTTLE PICTURE        * "
Wscript.StdOut.WriteLine "*                  FOR VICKY                  * "
Wscript.StdOut.WriteLine "*           version 1.0  2013/11/23           * "
Wscript.StdOut.WriteLine "*********************************************** "
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine "Please Input which Colunm that you want to insert the pictures ? "

excelname=inputbox("Please Input the dirction and file name of the excel you want to process:")
no=cdbl(inputbox("Please Input which Colunm that you want to insert the pictures:")) 

Set fso=CreateObject("Scripting.FileSystemObject")
Set xlapp = CreateObject("Excel.Application")
Set xlbook = Nothing
Set xlsheet = Nothing
Set xlbook = xlapp.Workbooks.Open(excelname)
Set xlsheet = xlbook.Worksheets(1)

intRow = 2               '''''''''''''''''''''''如果不想从第二行开始插入，可以修改参数intRow

Do Until xlsheet.Cells(intRow,1).Value = ""

     bottle_no=xlsheet.Cells(intRow,1).Value        
     xlapp.Visible = False
     xlsheet.Cells(intRow,no).Select
     
    Tpic = "d:"&bottle_no&".jpg"             '''''''''''''''''''在这里修改图片的文件夹路径
           
    If fso.fileExists(Tpic) Then
 
        set MyPic  =  xlsheet.Pictures.Insert(Tpic)
        
        MyPic.ShapeRange.Width=xlsheet.Cells(intRow,no+1).Left-xlsheet.Cells(intRow,no).Left-4
        MyPic.ShapeRange.Height=xlsheet.Cells(intRow+1,no).Top-xlsheet.Cells(intRow,no).Top-4
        
        MyPic.ShapeRange.Left=xlsheet.Cells(intRow,no).Left+((xlsheet.Cells(intRow,no+1).Left-xlsheet.Cells(intRow,no).Left-MyPic.ShapeRange.Width)/2)
        MyPic.ShapeRange.Top=xlsheet.Cells(intRow,no).Top+2
     
    End If
    
    intRow = intRow + 1 
    
Loop

xlbook.Save()
xlbook.Close()
xlapp.Quit

Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine "Pictures Inserting finished, press any key to exit !!!"
Wscript.StdIn.ReadLine

设置图片旋转为横向：

Dim fso
Wscript.StdOut.WriteLine "*********************************************** "
Wscript.StdOut.WriteLine "*       AUTO INSERT WIN BOTTLE PICTURE        * "
Wscript.StdOut.WriteLine "*                  FOR VICKY                  * "
Wscript.StdOut.WriteLine "*           version 1.0  2013/11/23           * "
Wscript.StdOut.WriteLine "*********************************************** "
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine "Please Input which Colunm that you want to insert the pictures ? "

excelname=inputbox("Please Input the dirction and file name of the excel you want to process:")
no=cdbl(inputbox("Please Input which Colunm that you want to insert the pictures:")) 

Set fso=CreateObject("Scripting.FileSystemObject")
Set xlapp = CreateObject("Excel.Application")
Set xlbook = Nothing
Set xlsheet = Nothing
Set xlbook = xlapp.Workbooks.Open(excelname)
Set xlsheet = xlbook.Worksheets(1)

intRow = 2             '''''''''''''''''''''''如果不想从第二行开始插入，可以修改参数intRow

Do Until xlsheet.Cells(intRow,1).Value = ""

     bottle_no=xlsheet.Cells(intRow,1).Value        
     xlapp.Visible = False
     xlsheet.Cells(intRow,no).Select
     
    Tpic = "d:"&bottle_no&".jpg"             '''''''''''''''''''在这里修改图片的文件夹路径
           
    If fso.fileExists(Tpic) Then
 
        set MyPic  =  xlsheet.Pictures.Insert(Tpic)
        MyPic.ShapeRange.IncrementRotation  270
        
       MyPic.ShapeRange.Height=xlsheet.Cells(intRow,no+1).Left-xlsheet.Cells(intRow,no).Left-4
        MyPic.ShapeRange.Width=xlsheet.Cells(intRow+1,no).Top-xlsheet.Cells(intRow,no).Top-4
        
        MyPic.ShapeRange.Left=xlsheet.Cells(intRow,no).Left+((xlsheet.Cells(intRow,no+1).Left-xlsheet.Cells(intRow,no).Left-MyPic.ShapeRange.Width)/2)
        MyPic.ShapeRange.Top=xlsheet.Cells(intRow,no).Top-((MyPic.ShapeRange.Height-xlsheet.Cells(intRow+1,no).Top+xlsheet.Cells(intRow,no).Top)/2)
    
    End If
    
    intRow = intRow + 1 
    
Loop

xlbook.Save()
xlbook.Close()
xlapp.Quit

Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine ""
Wscript.StdOut.WriteLine "Pictures Inserting finished, press any key to exit !!!"
Wscript.StdIn.ReadLine

相关信息：

console中输入数字：no = cdbl(Wscript.StdIn.ReadLine)

选择excel单元格另一种方法：xlsheet.Range("E4").Select