如何点击表单控件按钮自动插入身份证扫描件，求助大家了

ly8421

问题：点击鉴定申报表2工作簿里面的表单控件按钮插入身份证扫描件，N1序号与数据库工作簿里面的序号要一致。 问题.zip (304.04 KB, 下载次数: 22)

2019-10-16 13:56 上传

点击文件名下载附件

ly8421

朱荣兴 发表于 2019-10-16 16:36
附件中并没有你的代码，所以，你所说的按钮消失的问题没法看，而且，你帖子求助的内容，跟你附件的中的问题 ...

求助如何插入身份证图片

ly8421

Sub 生成照片3()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
  Dim fs1$
  Dim d As Object
  p = Application.Max(Sheets("数据库").Columns(1))
  Set d = CreateObject("scripting.dictionary")
For Each a In Sheets("鉴定申报表2").Pictures
    a.Delete
Next
  If [n1].Value >= p + 1000 Then
  MsgBox "后面没有了!": Exit Sub
  End If
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
    fs1 = ThisWorkbook.Path & "\照片\" & CStr(Sheets("鉴定申报表2").[g5]) & "all" & ".jpg"
    If d.ExistsFile(fs1) = True Then
       Range("b10:d16").Select
       ActiveSheet.Pictures.Insert(fs1).Select
       With Selection.ShapeRange
         Selection.ShapeRange.LockAspectRatio = msoFalse
            .Top = Range("b10:d16").Top
            .Left = Range("b10:d16").Left
            .Width = Range("b10:d16").Width
            .Height = Range("b10:d16").Height
        End With
    End If
    [n4].Select
Application.ScreenUpdating = True
End Sub

ly8421

Sub 生成照片3()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
  Dim fs1$
  Dim d As Object
  p = Application.Max(Sheets("数据库").Columns(1))
  Set d = CreateObject("scripting.dictionary")
For Each a In Sheets("鉴定申报表2").Pictures
    a.Delete
Next
  If [n1].Value >= p + 1000 Then
  MsgBox "后面没有了!": Exit Sub
  End If
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
    fs1 = ThisWorkbook.Path & "\照片\" & CStr(Sheets("鉴定申报表2").[g5]) & "all" & ".jpg"
    If d.ExistsFile(fs1) = True Then
       Range("b10:d16").Select
       ActiveSheet.Pictures.Insert(fs1).Select
       With Selection.ShapeRange
         Selection.ShapeRange.LockAspectRatio = msoFalse
            .Top = Range("b10:d16").Top
            .Left = Range("b10:d16").Left
            .Width = Range("b10:d16").Width
            .Height = Range("b10:d16").Height
        End With
    End If
    [n4].Select
Application.ScreenUpdating = True
End Sub

ly8421

朱荣兴 发表于 2019-10-16 16:36
附件中并没有你的代码，所以，你所说的按钮消失的问题没法看，而且，你帖子求助的内容，跟你附件的中的问题 ...

Sub 生成照片3()
Application.ScreenUpdating = False '防止屏幕抖动,屏幕刷新禁止
  Dim fs1$
  Dim d As Object
  p = Application.Max(Sheets("数据库").Columns(1))
  Set d = CreateObject("scripting.dictionary")
For Each a In Sheets("鉴定申报表2").Pictures
    a.Delete
Next
  If [n1].Value >= p + 1000 Then
  MsgBox "后面没有了!": Exit Sub
  End If
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息
    fs1 = ThisWorkbook.Path & "\照片\" & CStr(Sheets("鉴定申报表2").[g5]) & "all" & ".jpg"
    If d.ExistsFile(fs1) = True Then
       Range("b10:d16").Select
       ActiveSheet.Pictures.Insert(fs1).Select
       With Selection.ShapeRange
         Selection.ShapeRange.LockAspectRatio = msoFalse
            .Top = Range("b10:d16").Top
            .Left = Range("b10:d16").Left
            .Width = Range("b10:d16").Width
            .Height = Range("b10:d16").Height
        End With
    End If
    [n4].Select
Application.ScreenUpdating = True
End Sub