添加的来自用户表单的图像的超链接链接不会打开

Question

嗨，我有用户表单，所有数据都从用户表单添加到“VehicleRejected”表中，但是我添加了一个代码供用户从他们的驱动器中选择图像，它会将超链接添加到单元格现在超链接不会打开并出现错误消息“无法打开特定文件”有人可以帮我解决代码

   Private Sub CommandButton3_Click()
  On Error GoTo errHandler:
  
  Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String


Application.EnableCancelKey = xlDisabled

Application.ScreenUpdating = False
Application.EnableEvents = False

''''''''''''''''''''

n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)

TextBox65 = strFileName  'use to save URL or Link from picture

If strFileName = "False" Then
    MsgBox "File Not Selected!"
    Else
    'load picture to Image control, using LoadPicture property
    Me.Image2.Picture = LoadPicture(strFileName)
    
End If

sh.Unprotect "1234"

sh.Range("i" & n + 1).Value = Me.TextBox65.Value

sh.Range("i" & n + 1).Select
    With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
  
sh.Protect "1234"

MsgBox "Updated Successfully!!!", vbInformation
Unload Me

Application.EnableEvents = True
Application.ScreenUpdating = True

Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select

Exit Sub

errHandler:
 MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
           & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please Contact Admin", vbCritical, "Error Message"

End Sub

Answer 1

我想知道是否可以将上传到 image2 中的用户表单上的图像也插入到与使用自动大小输入的日期在同一行的 I、J、K、L 列的工作表中调整。

是的，这是可能的。这是一个例子。我将在I10 中插入图像以进行演示。随意调整它以满足您的需要。

逻辑：

1. 获取用户的临时目录。
2. 使用SavePicture将图像控件中的图像保存到用户的临时目录。
3. 将临时目录中的图像插入到相关工作表中。
4. 根据需要调整大小。

代码：

Option Explicit

Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MAX_PATH As Long = 260

Private Sub CommandButton1_Click()
    Dim ws As Worksheet
    
    '~~> Change this to the relevant sheet
    Set ws = Sheet1
    
    Dim tempImagePath As String
    tempImagePath = TempPath & "Temp.jpg"
    
    '~~> Save the image to user's temp directory
    SavePicture Image1.Picture, tempImagePath
    
    DoEvents
    
    '~~> Insert the image in cell say I10 and resize it
    With ws.Pictures.Insert(tempImagePath)
        '~~> If LockAspectRatio  is set to true then Height and Width will not change
        '~~> as per cell height and width
        .ShapeRange.LockAspectRatio = msoFalse
        .Left = ws.Range("I10").Left
        .Top = ws.Range("I10").Top
        .Width = ws.Range("I10").Width
        .Height = ws.Range("I10").Height
    End With
End Sub

Function TempPath() As String
    TempPath = String$(MAX_PATH, Chr$(0))
    GetTempPath MAX_PATH, TempPath
    TempPath = Replace(TempPath, Chr$(0), "")
End Function

在行动：

Image attribution

Answer 2

您好 Siddharth，您的代码和其他一些代码正在播放，以下是我目前所获得的内容，它添加了图片的超链接，但是文件无法打开或找到。

Private Sub CommandButton3_Click()
  On Error GoTo errHandler:
  
  Dim sh As Worksheet
Set sh = ThisWorkbook.Sheets("VehicleRejected")
Dim n As Long
Dim answer As String
Dim strFileName As String


Application.EnableCancelKey = xlDisabled

Application.ScreenUpdating = False
Application.EnableEvents = False

''''''''''''''''''''

n = sh.Range("A" & Application.Rows.Count).End(xlUp).Row

strFileName = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Select a File", MultiSelect:=False)

TextBox65 = strFileName  'use to save URL or Link from picture

If strFileName = "False" Then
    MsgBox "File Not Selected!"
    Else
    'load picture to Image control, using LoadPicture property
    Me.Image2.Picture = LoadPicture(strFileName)
    
End If

sh.Unprotect "1234"

sh.Range("i" & n + 1).Value = Me.TextBox65.Value

sh.Range("i" & n + 1).Select
    With ActiveSheet
.Hyperlinks.Add Anchor:=sh.Range("i" & n + 1), Address:=",TextToDisplay, """
End With
  
sh.Protect "1234"

MsgBox "Updated Successfully!!!", vbInformation
Unload Me

Application.EnableEvents = True
Application.ScreenUpdating = True

Worksheets("VehicleRejected").Activate
Worksheets("VehicleRejected").Cells(1, 3).Select

Exit Sub

errHandler:
 MsgBox "An Error has Occurred  " & vbCrLf & "The error number is:  " _
           & Err.Number & vbCrLf & Err.Description & vbCrLf & _
           "Please Contact Admin", vbCritical, "Error Message"

End Sub