[源创]Access控制excel插入图片

tmtony

有网友问起,发一下以前写过的代码,内容不能直接 运行,只是给大家看懂代码 就可改为自己使用了  
Access控制excel插入图片 --tmtony

strPicPath = strPicPath1 & "\" & Trim$(pstr2) & ".bmp"
If Dir(strPicPath) = "" Then
     strPicPath = strPicPath2 & "\" & Trim$(pstr2) & ".bmp"
    If Dir(strPicPath) = "" Then
      
        strPicPath = strEmptyPath
    End If
End If
    xlsWSheet.Range("C54").Select
    xlsWSheet.Pictures.Insert(strPicPath).Select
    xlsApp.Selection.ShapeRange.ScaleWidth 0.4, msoFalse, msoScaleFromTopLeft
    xlsApp.Selection.ShapeRange.ScaleHeight 0.4, msoFalse, msoScaleFromTopLeft
    xlsApp.Selection.ShapeRange.ScaleWidth 0.4, msoFalse, msoScaleFromTopLeft
    xlsApp.Selection.ShapeRange.ScaleHeight 0.4, msoFalse, msoScaleFromTopLeft

li08hua

好东东，我正在找呢，原来是跑到您哪儿去了（我的代码记不住放到什么地方了）。谢谢还我！

tmtony

哈哈, 厉害, 下次我找不到代码,也问你.

lzongb

谢谢管理员，我的问题已经搞定了。完整代码（借鉴了网络搜索结果）如下：

Private Sub InsertPicture(PictureFileName As String, TargetCell As Range, CenterH As Boolean, CenterV As Boolean)
'在显示区域中插入图片，可以水平居中或垂直居中，还可以缩小以适应显示区域
    Dim p As Excel.Picture, _
        sh As Excel.Shape, _
        t As Double, l As Double, _
        w As Double, h As Double, _
        wRatio As Double, _
        hRatio As Double

    With TargetCell
        
        For Each sh In .Parent.Shapes '当连续打印时，删除上一户的图片
            If sh.Type = msoLinkedPicture Then sh.Delete
        Next
        
        If PictureFileName = "" Then Exit Sub '未指定图片
        If Dir(PictureFileName) = "" Then Exit Sub '指定的图片文件不存在
        
        Set p = .Parent.Pictures.Insert(PictureFileName)
        
        t = .Top
        l = .Left
        w = .Offset(0, 1).Left - .Left
        h = .Offset(1, 0).Top - .Top
        
        wRatio = Round(w / p.Width, 2)
        hRatio = Round(h / p.Height, 2)
        
        If wRatio < 1 Or hRatio < 1 Then  '当图片大于显示区域时进行缩小
            p.ShapeRange.LockAspectRatio = msoTrue
            If wRatio < hRatio Then
                p.ShapeRange.ScaleWidth wRatio, msoTrue, msoScaleFromMiddle
                p.ShapeRange.ScaleHeight wRatio, msoTrue, msoScaleFromMiddle
            Else
                p.ShapeRange.ScaleHeight hRatio, msoTrue, msoScaleFromMiddle
                p.ShapeRange.ScaleWidth hRatio, msoTrue, msoScaleFromMiddle
            End If
        End If
        
        If CenterH Then '水平居中
            l = l + w / 2 - p.Width / 2
            If l < 1 Then l = 1
        End If
        If CenterV Then  '垂直居中
            t = t + h / 2 - p.Height / 2
            If t < 1 Then t = 1
        End If
    End With
    ' position picture
    With p
        .Top = t
        .Left = l
    End With
    Set p = Nothing
End Sub

用法示例：InsertPicture "d:\demo.bmp",xlBook.worksheets(1).Range("D1"),true,true

tmtony

谢谢分享!!

li08hua

lzongb 的功能似乎更强大，连同tmtony 一起谢谢了！