Sub importmap()
'说明：此插件，针对于蒲江行道树保护公示牌，尺寸170*110，插入二维码使用。
'运用合并打印的方式，得到左侧或者右侧行道树的版面。
'运用草料二维码在线生成二维码，以行道树编号命名二维码图片。如Z0001.png,Y0001.png
'再结合其他插件，完成拼版。
'如果用于其他版面，通过录制宏的方式，得到相应插入二维码的位置参数进行修改。
'时间:




    Dim impopt As StructImportOptions
   
    Set impopt = CreateStructImportOptions
    With impopt
        .Mode = cdrImportFull
        .MaintainLayers = True
        With .ColorConversionOptions
            .SourceColorProfileList = "sRGB IEC61966-2.1,Japan Color 2001 Coated,Dot Gain 15%"
            .TargetColorProfileList = "sRGB IEC61966-2.1,Japan Color 2001 Coated,Dot Gain 15%"
        End With
    End With
    '-------------------------------------  主体代码开始  ----------------------------
    Dim PIC$, pth$, shp As Shape, picarr, p%, js, NON%, rl, mappth$
    '定义所用的变量
    '$字符串型，外型像S，所以是string，文字型 ，dim i as string
    '！单精度浮点数，1个感叹号，所以是单精度,dim i as single
    '# 双精度浮点数，二横二竖，所以是双精度,dim i as doule
    '& 长整型 外形像L的花体字，所以是Long，长整型,dim i as long
    '@ 货币型 @ = price,dim i as currency
    '% 整型  百分比符号，百来个整数，integer整数型,dim i as integer

        picarr = Array(".jpg", ".png")
        '数组集合，几种类型的格式
        
        mappth = InputBox("粘贴二维码所在文件夹路径")
        rl = InputBox("输入大写Z或者Y")
        '弹出输入框，获取路径和左右侧字母
        
        pth = mappth & "\"
        '使获取的路径，完整化，便于之后组合图片完整路径
        
        For p = 1 To ActiveDocument.Pages.Count
        '因为是用合并打印的方式创建的多页面，所以需要从第一页到最后一页，以每页页码对应每项数据
        
        If p < 10 Then
        
            js = rl & "000"
        
        ElseIf p > 9 And p < 100 Then
        
            js = rl & "00"
        
        ElseIf p > 99 Then
        
            js = rl & "0"
        
        End If
        '判断页码，使页码与二维码图片名字相匹配
        
        For x = 0 To UBound(picarr)
          '循环组合几种格式
        
        PIC = pth & js & p & picarr(x)
        '拼接成完整的二维码图片路径
        
            If Dir(PIC) <> "" Then
    
    Dim impflt As ImportFilter
    Set impflt = ActiveDocument.Pages(p).Layers("图层 1").ImportEx(PIC, cdrPNG, impopt)
    impflt.Finish
    '插入二维码进页面
    Set shp = ActiveShape
    ActiveDocument.Pages(p).Layers("图层 1").Shapes(1).Move 2.369075, 0.33539
    '再移动到相应的位置
    '以上是通过录制宏，得到插入二维码的方式和位置
    
    NON = 1
    '执行成功的判断
            End If
               
        Next x
        
        If NON <> 1 Then
        MsgBox "NO PIC", 48, "Close"
        Exit Sub
         '执行不成功提示，没有图片，或者没有找到相对应的图片，就退出程序
        End If
        
        Next p
        '循环下一页
End Sub