1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56
|
Sub insertBitmap(cxlapp As Excel.Application, r As Long, c As Long, path As String, xscale As String, ier As Long)
Dim ra As Range
Dim ident As String
Dim cxscale As String
Dim rw As Double
Dim rh As Double
Dim rx As Double
Dim ry As Double
Dim px As Double
Dim py As Double
If (r <= 0 Or c <= 0) Then GoTo cleanup
ier = -1
cxscale = xscale
If (cxscale = "") Then cxscale = 1
ident = Chr$(64 + c) & r & ":" & Chr$(64 + c) & r
'vista compatible
On Error GoTo errors
Set ra = cxlapp.Range(ident)
If (ra Is Nothing) Then GoTo cleanup
ra.Select
If (ra.MergeCells) Then
rw = ra.MergeArea.width
rh = ra.MergeArea.height
Else
rw = ra.width
rh = ra.height
End If
cxlapp.ActiveSheet.Pictures.Insert(path).Select
cxlapp.Selection.ShapeRange.LockAspectRatio = msoFalse
Call cxlapp.Selection.ShapeRange.ScaleWidth(cxscale, msoTrue, msoScaleFromTopLeft) 'msoScaleFromMiddle
Call cxlapp.Selection.ShapeRange.ScaleHeight(cxscale, msoTrue, msoScaleFromTopLeft)
cxlapp.Selection.ShapeRange.Top = ra.Top
cxlapp.Selection.ShapeRange.Left = ra.Left
rx = (rw / 2)
ry = (rh / 2)
px = (cxlapp.Selection.ShapeRange.width / 2)
py = (cxlapp.Selection.ShapeRange.height / 2)
Call cxlapp.Selection.ShapeRange.IncrementLeft(rx - px)
Call cxlapp.Selection.ShapeRange.IncrementTop(ry - py)
ier = 0
GoTo cleanup
errors:
MsgBox ("insertBitmap error")
cleanup:
Set ra = Nothing
End Sub |
Partager