小明 和 VBA 的第一次约会

唠嗑老掉牙的一小段

　　我第一次对 EXcel 有感觉，应该是早些年在富士康实践的时候。那时候是在 FQC 岗位做事，有次在过年值夜班比较闲的时候，用了 Excel 做了个工资的计算，其中是利用了 Excel 一些简单的公式来计算的。那时候还很年轻，这个小小的作品也感到小小的喜悦，因为做出来，好多同事也用上了。（那时候工作的电脑只能查看内部网的“新闻”，手机也只能一些干部携带到工作区，数据的拷贝还是用的软盘，没错，就是存储容量1到2 m 容量的软盘）

　　这应该是我第一次间接地爱恋了 VBA（Visual Basic for Applications） 吧。

---

问题的应用场景

　　最近我们做了个导出数据表报，其中报表中有图片。考虑到直接在服务器上下载图片并把图片塞到报表中，然后生成文件返回，这样对服务器的内存资源有很大的消耗，我们考虑在客户端实现图片的下载并放置到报表中。

于是我开始看了Excel 的 VBA （Visual Basic for Applications）。这应该就是我和 VBA  阔别多年的第一次约会了。

---

VBA 实现Excel的图片下载操作。

　　查阅了两天的资料，我简单的实现了根据 Excel 表中的某列值（图片链接）下载图片放置到对应行的某列中。

实现思路是：1、遍历 Excel 表中的图片链接列，拿到图片链接；

                     2、下载图片，把图片文件临时保存到本地磁盘中；

　　　　　　3、将图片插入到 Excel 的图层中，调整图片的位置以及大小

---

实现效果

原始报表

在客户端下载图片

---

VBA 代码

思路简单，代码实现也简单（原始初级low），上代码

'download the picture from net
'by wmy at 2018/05/14
Option Explicit
Public isLoadImage As Boolean

'必须控件：按钮【CommandButton1】，按钮控件的名称为：CommandButton1
'使用说明：根据 【图片地址列】 去下载网络图片，放置到对应行的 【下载图片即将放置列】
'          根据报表需求，对应修改 【图片地址列】和 【下载图片即将放置列】
'          对应参数为：imgUrlColumIdx，imgColumIdx
Private Sub CommandButton1_Click()
    Dim txtUrl As String
    Dim loadTag As String
    Dim Asheet As Worksheet
    Dim r As Integer
    Dim i As Integer
    Dim imgUrlColumIdx As Integer
    Dim imgColumIdx As Integer
    r = Sheet1.UsedRange.Rows.Count
    i = 2
    imgUrlColumIdx = 3 'URL 图片地址列
    imgColumIdx = 4    '下载图片即将放置列
    Set Asheet = Me
    isLoadImage = IsExistPics()
    If (isLoadImage = False) Then
        Call ClearPics
        Do While i <= r
            txtUrl = Asheet.Cells(i, imgUrlColumIdx).Value
            If VarType(Asheet.Cells(i, imgUrlColumIdx)) > vbEmpty Then
                If VarType(Asheet.Cells(i, imgUrlColumIdx)) = vbString Then
                    If VarType(Asheet.Cells(i, imgColumIdx)) = vbEmpty Then DownNetFile txtUrl, "C:xiaoming-vab-temporary.jpg", i, imgColumIdx
                End If
            End If
            i = i + 1
        Loop
        isLoadImage = True
    Else
        Dim BoxResponse As Variant
        BoxResponse = MsgBox("图片已经下载。 " & Chr(13) & "您是想要重新下载所有图片吗？", vbYesNo, "BG报表信息提示")
        If BoxResponse = vbYes Then
            Call ClearPics
            Do While i <= r
                txtUrl = Asheet.Cells(i, imgUrlColumIdx).Value
                If VarType(Asheet.Cells(i, imgUrlColumIdx)) > vbEmpty Then
                    If VarType(Asheet.Cells(i, imgUrlColumIdx)) = vbString Then
                        If VarType(Asheet.Cells(i, imgColumIdx)) = vbEmpty Then DownNetFile txtUrl, "C:xiaoming-vab-temporary.jpg", i, imgColumIdx
                    End If
                End If
                i = i + 1
            Loop
            isLoadImage = True
        End If
    End If
End Sub
'download the picture from web,and insert to the active sheet
Private Sub DownNetFile(ByVal nUrl As String, ByVal nFile As String, rowIdx As Integer, colIdx As Integer)
Dim XmlHttp, B() As Byte
Set XmlHttp = CreateObject("Microsoft.XMLHTTP")
XmlHttp.Open "GET", nUrl, False
XmlHttp.Send
If XmlHttp.ReadyState = 4 And XmlHttp.Status = 200 Then
B() = XmlHttp.ResponseBody
Open nFile For Binary As #1
Put #1, , B()
Close #1
End If
Set XmlHttp = Nothing

'Dim img As Image
'Set img = New Image
'Set img.Picture = LoadPicture(nFile)
'Me.Cells(rowIdx, colIdx + 1) = img
Dim rng As Variant
Dim FilePath As String
Dim Asheet As Worksheet
Set Asheet = Me
With Asheet
    FilePath = nFile
    If Dir(FilePath) <> "" Then
    .Pictures.Insert(FilePath).Select
    Set rng = .Cells(rowIdx, colIdx)
    With Selection
         .Top = rng.Top + 1
         .Left = rng.Left + 1
         .Width = rng.Width - 1
         .Height = rng.Height - 1
    End With
End If
End With
Kill (FilePath)
End Sub
'delete all pictures in active sheet, but do not include the buttom
Sub ClearPics()
    Dim Shp As Shape
    For Each Shp In Me.Shapes
    If Shp.Type = 13 Then Shp.Delete
    Next
End Sub
'is there any picture inserted
Function IsExistPics()
    Dim isExist As Boolean
    isExist = False
    Dim Shp As Shape
    For Each Shp In Me.Shapes
        If Shp.Type = 13 Then
            isExist = True
            Exit For
        End If
    Next
    IsExistPics = isExist
End Function

---

希望，是看不见的空气，却照在心里的光芒

 　　第一次约会，写得low！当作学习笔记吧。希望帮助到能帮助的，也希望抛砖引玉，在评论区的VIP沙发上有大神的高见，一起交流学习。

---

本文路径：http://www.cnblogs.com/youler/p/9046358.html

---