Question

几个星期前，我问了这个问题，并且有了＃34;＆＃34;解决了，但仍有bug。这就是我需要发生的事情：

我有一张Excel工作表并创建了一个具有InkPicture Box的UserForm，并设置为允许某人打开用户表单并绘制他们的签名。分配了一个CommandButton来获取签名并将其从剪贴板保存到PC上。我有另一个CommandButton分配从PC路径检索所保存的图片，并将其带回我的工作簿中的特定工作表，并将其插入特定的单元格。

我的需求如下：我需要使用代码来更新每次单击按钮时插入图像的单元格。（换句话说。每当我按下按钮并且在它恢复到C3之后，我需要代码从C3增加到C50，增加一个数字）

Bug I仍然基本上完成了三个单元格的完美插入，然后它被卡住并将其余图片插入到同一个单元格中。以下是我使用的代码：

Private Sub CommandButton4_Click()

Dim ws As Worksheet
Dim ImgPath As String
Dim W As Double, H As Double
Dim L As Long, T As Long
Dim myArr() As Variant, myArrCounter As Long
Dim newRowNumb As Long

Set ws = ThisWorkbook.Sheets("Mobile POS Log Sheet")

'////////////////////////////////////////   This section will find the row of the bottom most shape in Column C
ReDim myArr(1 To 1)
myArrCounter = 0

For Each wshape In ws.Shapes
myArrCounter = myArrCounter + 1
If myArrCounter = 1 And wshape.TopLeftCell.Column = 3 Then
    myArr(myArrCounter) = wshape.TopLeftCell.row
Else:
    If wshape.TopLeftCell.Column = 3 And wshape.TopLeftCell.row > myArr(UBound(myArr)) Then
        ReDim Preserve myArr(1 To myArrCounter)
        myArr(myArrCounter) = wshape.TopLeftCell.row
    End If
End If
Next wshape
newRowNumb = myArr(UBound(myArr)) + 1 ' this adds two rows to place the new picure.  



'~~> This is my current pic file path
ImgPath = "C:\Users\raphaelo\Downloads\test.gif"


With ws
    W = 30                  '<~~ Width
    H = 11                  '<~~ Height
    L = .Range("c" & newRowNumb).Left   '<~~ This is what should be changing each time I run the command
    T = .Range("c" & newRowNumb).Top    '<~~ This is what should be changing each time I run the command
     '<~~ Both the L and T Range entries should change to the next cell (C3 to C4 to C5 and so on) One digit up every time I run the Command Code
     '<~~ Unless it's the Placement entry below?
    With .Pictures.Insert(ImgPath)
        With .ShapeRange
            .LockAspectRatio = msoTrue
            .Width = W
            .Height = H
        End With
        .Left = L
        .Top = T
        .Placement = 1 '<~~ Not sure if this is the one that should change one digit up each time I run the Command instead?
    End With
End With

End Sub

Answer 1

跟踪图片位置很棘手，所以我采取了不同的方法：

Public Sub CommandButton4_Click()
    'Use Const for fixed values...
    Const PIC_FLAG As String = "PIC"
    Const IMG_PATH As String = "C:\_Stuff\test\test.png"
    Const MAX_ROW As Long = 50
    Const W As Long = 30
    Const H As Long = 11

    Dim ws As Worksheet, c As Range
    Set ws = ThisWorkbook.Sheets("Mobile POS Log Sheet")

    Set c = ws.Range("C3")
    'find first empty cell
    Do While c.Value = PIC_FLAG And c.Row < MAX_ROW 
        Set c = c.Offset(1, 0)
    Loop

    If c.Value = PIC_FLAG Then
        MsgBox "No rows left!"
        Exit Sub
    End If

    With ws.Pictures.Insert(IMG_PATH)
         With .ShapeRange
             'if you lock the aspect ration then
             '  adjusting both W and H might give
             '  odd results...
             .LockAspectRatio = msoTrue
             .Width = W
             .Height = H
         End With
         .Left = c.Left
         .Top = c.Top
         .Placement = 1
     End With
     c.Value = PIC_FLAG     '<< flag has pic
     c.Font.Color = vbWhite '<< hide the flag

End Sub

我的UserForm代码中有一个错误，它将保存的图片插入excel到下一个单元格

1 个答案: