解决ACCESS2007导出带图片EXCEL问题

时　间:2013-12-18 11:48:13
作　者:luboo   ID：20748  城市：广州
摘　要:导出带图片excel
正　文:

下载了论坛里以前的例子，一直有图片叠在一块的问题。

然后参考网上的例子，跑到EXCEL里去建宏，用的还是：.ActiveSheet.Pictures.Insert(strPic).Select这句代码。还是会叠到一块。

最后去EXCEL帮助里搜，搜到这句代码：

Set myDocument = Worksheets(1)
myDocument.Shapes.AddPicture _
    "c:\microsoft office\clipart\music.bmp", _
    True, True, 100, 100, 70, 70

实验证明是可用的。前两个100是位置，后面两个70是大小。

把论坛里的例子代码改了一下用在我的程序里，如下：

    Dim strTemplate As String           '模板文件路径名
    Dim strPathName As String           '输出文件路径名
    Dim objApp As Object                'Excel程序
    Dim objBook As Object               'Excel工作簿
    Dim rst As Object                   '子窗体记录集
    Dim intN As Integer                 '循环计数器
    Dim blnNoQuit   As Boolean          '此标记为True时不关闭Excel
    Dim strPicPath As String            '图片路径
    Dim strPic, strPicM As String               '
    
    '当前是新记录则提示并退出
    If DCount("采购明细ID", "采购明细查询", "采购ID = " & [采购ID]) = 0 Then
        MsgBox "当前没有数据可导出！", vbExclamation, "提示"
        Exit Sub
    End If


    '模板文件路径
    strTemplate = CurrentProject.Path & "\订单模板.xls"
    '图片文件夹路径
    strPicPath = CurrentProject.Path & "\pics\"
    '默认保存的文件名
    strPathName = CurrentProject.Path & "\" & Me.日期 & ".xls"
    
    '通过文件对话框取得另存为文件名
    With FileDialog(2)    'msoFileDialogSaveAs
        .InitialFileName = strPathName
        If .Show Then
            strPathName = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    
    '如果文件名后没有.xls扩展名则加上
    If Not strPathName Like "*.xls" Then strPathName = strPathName & ".xls"
    '删除已有文件
    If Dir(strPathName) <> "" Then Kill strPathName


    '设置鼠标指针为沙漏形状
    DoCmd.Hourglass True
    '创建Excel对象
    Set objApp = CreateObject("Excel.Application")
    '打开模板文件
    Set objBook = objApp.Workbooks.Open(strTemplate)
    objBook.Sheets("销售订单").Select
    With objApp
        
        Set rst = Me.采购明细查询.Form.Recordset
        If rst.RecordCount > 0 Then rst.MoveFirst
        intN = 2
        Do Until rst.EOF


            '写入订单明细
            .Range("C" & intN) = rst!品名
            .Range("D" & intN) = rst![品名（韩文）]
            .Range("E" & intN) = rst!官方价格
            .Range("F" & intN) = rst!单价
            .Range("G" & intN) = rst!数量
            '.Range("A" & intN).Select
            strPic = strPicPath & rst![产品ID] & ".jpg"
            strPicM = strPicPath & rst![主ID] & ".jpg"
            objBook.Sheets("销售订单").Shapes.AddPicture strPicM, True, True, 3, intN * 75 - 130, 70, 70
            If strPic <> strPicM Then objBook.Sheets("销售订单").Shapes.AddPicture strPic, True, True, 78, intN * 75 - 130, 70, 70
            
            '.ActiveSheet.Pictures.Insert(strPic).Select
              '调整图片位置
            '.Selection.ShapeRange.IncrementLeft 2
            '.Selection.ShapeRange.IncrementTop 2
              '调整图片大小
            '.Selection.ShapeRange.Width = 98
            '.Selection.ShapeRange.Height = 98
            
            rst.MoveNext
            intN = intN + 1
        Loop


    End With
    '保存Excel文件，因为模板是不能修改的，所以是另存为
    objBook.SaveAs strPathName


    Beep
    
    If MsgBox("导出已完成，是否打开导出的Excel文件？", vbQuestion + vbYesNo, "导出完成") = vbYes Then
        objApp.Visible = True
        objBook.Saved = True
        blnNoQuit = True
        '自动进入打印预览
        'objApp.ActiveWindow.SelectedSheets.PrintPreview
    End If


    '恢复鼠标指针
    DoCmd.Hourglass False
    '释放对象变量内存
    Set objApp = Nothing
    Set objBook = Nothing
    Set rst = Nothing
    Exit Sub