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

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

标签： excelvba

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

在行动：

图片归属地