关于生成Excel图片对象，VBA与VB的编写不同

日本人VBA写的二维码生成工具，想移植到vb6.0，写com组件，不废话，直接上代码

vba原代码

Private m_fs As Object

Public Function QR(ByVal s As String, _
                   Optional ByVal charsetName As String = "Shift_JIS") As Variant
    If m_fs Is Nothing Then
        Set m_fs = CreateObject("Scripting.FileSystemObject")
    End If

On Error GoTo Catch
    If Not (TypeOf Application.Caller Is Range) Then Exit Function

    Dim rng As Range
    Set rng = Application.Caller.MergeArea
    Call DeleteShape(rng)

    If Len(s) = 0 Then Exit Function

    Dim sbls As Symbols
    Set sbls = CreateSymbols(charsetName:=charsetName)
    Call sbls.AppendText(s)

    Dim filePath As String
    filePath =  "D:\test.jpg" 
  
    Dim shp As Shape
    Set shp = AddPicture(filePath, rng)
    Call FillShape(shp, vbWhite)

    QR = ""

Finally:
On Error GoTo 0
    Exit Function
Catch:
    QR = CVErr(xlErrValue)
    Resume Finally
End Function

Private Function DeleteShape(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Target.Parent

    Dim shps As Shapes
    Set shps = ws.Shapes

    Dim shp As Shape
    Dim rng As Range
    Dim i As Long
    For i = shps.Count To 1 Step -1
        Set shp = shps(i)
        If shp.Type = msoPicture Then
            Set rng = ws.Range(shp.TopLeftCell, shp.BottomRightCell)
            If Not (Intersect(Target, rng) Is Nothing) Then shp.Delete
        End If
    Next
End Function

Private Function AddPicture(ByVal filePath As String, ByVal Target As Range) As Shape
    Dim shps As Shapes
    Set shps = Target.Parent.Shapes

    Dim shp As Shape
    Set shp = shps.AddPicture(filePath, msoFalse, msoTrue, Target.Left, Target.Top, 0, 0)

    With shp
        Call .ScaleHeight(1, msoTrue)
        Call .ScaleWidth(1, msoTrue)
        .LockAspectRatio = msoTrue
        .Placement = xlMoveAndSize
    End With

    If Target.Height * shp.Width <= Target.Width * shp.Height Then
        shp.Height = Target.Height - 10
    Else
        shp.Width = Target.Width - 10
    End If

    shp.Left = Target.Left + Target.Width / 2 - shp.Width / 2
    shp.Top = Target.Top + Target.Height / 2 - shp.Height / 2

    Set AddPicture = shp
End Function

Private Sub FillShape(ByVal shp As Shape, ByVal colorRgb)
    With shp.Fill
        .ForeColor.RGB = colorRgb
        .Transparency = 0
        .Solid
    End With
End Sub

vb6.0下正常调用的代码：

需要在模块申明公共变量Public excelapp As Excel.Application

Private m_fs As Object
Public Function QR(ByVal s As String, _
                   Optional ByVal charsetName As String = "Shift_JIS") As Variant
    If m_fs Is Nothing Then
        Set m_fs = CreateObject("Scripting.FileSystemObject")
    End If

On Error GoTo Catch
    If Not (TypeOf excelapp.Caller Is Excel.Range) Then Exit Function

    Dim rng As Range
    Set rng = excelapp.Caller.MergeArea
    Call DeleteShape(rng)

     If Len(s) = 0 Then Exit Function

    'Dim sbls As Symbols
    'Set sbls = CreateSymbols(charsetName:=charsetName)
    'Call sbls.AppendText(s)

    Dim filePath As String
    filePath = "G:\迅雷下载\pic\pics5.jpg"

    'If m_fs.FileExists(filePath) Then Call m_fs.DeleteFile(filePath)
   ' Call sbls(0).SaveAs(filePath, fmt:=fmtEMF)

    Dim shp As Excel.Shape
    Set shp = AddPicture(filePath, rng)
    Call FillShape(shp, vbWhite)

    QR = ""

Finally:
On Error GoTo 0
   ' If m_fs.FileExists(filePath) Then Call m_fs.DeleteFile(filePath)
    Exit Function
Catch:
    QR = CVErr(xlErrValue)
    Resume Finally
End Function

Private Function DeleteShape(ByVal Target As Range)
    Dim ws As Worksheet
    Set ws = Target.Parent

    Dim shps As Excel.Shapes
    Set shps = ws.Shapes

    Dim shp As Excel.Shape
    Dim rng As Range
    Dim i As Long
    For i = shps.Count To 1 Step -1
        Set shp = shps(i)
        If shp.Type = msoPicture Then
            Set rng = ws.Range(shp.TopLeftCell, shp.BottomRightCell)
            If Not (Intersect(Target, rng) Is Nothing) Then shp.Delete
        End If
    Next
End Function

Private Function AddPicture(ByVal filePath As String, ByVal Target As Range) As Excel.Shape
    Dim shps As Excel.Shapes
    Set shps = Target.Parent.Shapes
    'MsgBox Target.Parent.Name
    Dim shp As Excel.Shape
    Set shp = Target.Parent.Shapes.AddPicture(filePath, True, True, Target.Left, Target.Top, 10, 10)

     With shp
        Call .ScaleHeight(1, msoTrue)
        Call .ScaleWidth(1, msoTrue)
        .LockAspectRatio = msoTrue
        .Placement = xlMoveAndSize
    End With

    If Target.Height * shp.Width <= Target.Width * shp.Height Then
        shp.Height = Target.Height - 10
    Else
        shp.Width = Target.Width - 10
    End If

    shp.Left = Target.Left + Target.Width / 2 - shp.Width / 2
    shp.Top = Target.Top + Target.Height / 2 - shp.Height / 2

    Set AddPicture = shp
End Function

Private Sub FillShape(ByVal shp As Excel.Shape, ByVal colorRgb)
    With shp.Fill
        .ForeColor.RGB = colorRgb
        .Transparency = 0
        .Solid
    End With
End Sub