台灣最大程式設計社群網站
線上人數
1553
 
會員總數:242949
討論主題:187843
歡迎您免費加入會員
討論區列表 >> office VBA / WinOS >> 他是用路徑連結,不適用插入圖片,導致傳給人EXCEL都顯示不出圖片,如何改?
[]  
[我要回覆]
回應主題 加入我的關注話題 檢舉此篇討論 將提問者加入個人黑名單
他是用路徑連結,不適用插入圖片,導致傳給人EXCEL都顯示不出圖片,如何改?
價值 : 10 QP  點閱數:453 回應數:0

樓主

蠻牛
門外漢
0 1
8 0
發送站內信

他是用路徑連結,不適用插入圖片,導致傳給人EXCEL都顯示不出圖片



Option Explicit
Function getLastUsedRow(ws As Worksheet) As Long

Dim lastUsedRow As Long: lastUsedRow = 1
On Error Resume Next
lastUsedRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
On Error GoTo 0

getLastUsedRow = lastUsedRow

End Function

Sub 插入產品圖片()

Application.ScreenUpdating = False

Dim i As Long
Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")

' --------------------------------------------------------------------------------------------
' ----------------------------- VARIABLES FOR ACTIVE SHEET ! ---------------------------------
' --------------------------------------------------------------------------------------------
Dim wsData As Worksheet: Set wsData = ActiveSheet
Dim wsDataStartingRowAnswer As String ' Answer user gave for what is the starting row for the processing !
Dim wsDataStartingRow As Long ' Starting row !
Dim wsDataEndingRow As Long: wsDataEndingRow = getLastUsedRow(wsData) ' Global ending row on the whole sheet !
Dim wsDataProductNumberColumn As String
Dim wsDataProductPictureColumn As String
Dim wsDataProductNumber As String ' Current product number !
Dim wsDataProductPicturePath As String ' Current product picture file system path !
' --------------------------------------------------------------------------------------------

' --------------------------------------------------------------------------------------------
' ----------------------------- VARIABLES FOR FILE SYSTEM ! ----------------------------------
' --------------------------------------------------------------------------------------------
Dim path As String: path = ThisWorkbook.path
Dim picturesFolderName As String: picturesFolderName = "64x64"
'Dim picturesFolderPath As String: picturesFolderPath = path + Application.PathSeparator + picturesFolderName
Dim picturesFolderPath As String: picturesFolderPath = "M:\" + Application.PathSeparator + picturesFolderName
Dim importPicture As Object
' --------------------------------------------------------------------------------------------

' --------------------------------------------------------------------------------------------
' ------- CHECKING IF PICTURES FOLDER EXISTS IN THE SAME DIRECTORY AS CURRENT FILE ! ---------
' --------------------------------------------------------------------------------------------

If Not fso.FolderExists(picturesFolderPath) Then
' MsgBox "Folder named: " + picturesFolderName + " must be in the same directory as this file, please create it and run macro again!"
MsgBox "放置圖片的檔案夾找不到, 請確定有這個資料夾" + picturesFolderName + " "
Exit Sub
End If

' --------------------------------------------------------------------------------------------

' --------------------------------------------------------------------------------------------
' ------------------ ASKING FOR USER INPUT AND CHECKING ITS VALIDITY ! -----------------------
' --------------------------------------------------------------------------------------------

' Ask the user "What is Product number column?" !
' wsDataProductNumberColumn = InputBox("Please enter column letter where product numbers are stored" + vbCrLf + "For example: A", "Product number column")
wsDataProductNumberColumn = InputBox("我將從檔案夾 'M:\64x64' 裡面, 尋找並加入圖片" + vbCrLf + "請問產品編號在哪一欄?" + vbCrLf + "例如: A", "產品欄")

' Check if user inputted anything in product number column !
If wsDataProductNumberColumn = "" Then
' MsgBox "Product number column must be provided, please enter it and run macro again!"
MsgBox "必須輸入產品欄位才能置入圖片啦"
Exit Sub
End If


' Ask the user "What is the starting row?" !
' wsDataStartingRowAnswer = InputBox("Please enter starting row?" + vbCrLf + "For example: 12", "Starting row")
wsDataStartingRowAnswer = InputBox("從哪一列開始置入圖片?" + vbCrLf + "例如: 2", "開始列")

' Check if user provided correct starting run number !
If Not IsNumeric(wsDataStartingRowAnswer) Then
' MsgBox "Starting row must be provided and in correct format, please enter starting row number and run macro again!"
MsgBox "開始列只能輸入數字, 請重新執行巨集"
Exit Sub
End If

' Convert user provided answer to whole number (long number) !
wsDataStartingRow = CLng(wsDataStartingRowAnswer)


' Check if provided answer for product number column is an actual column letter !
wsDataProductNumberColumn = Trim(wsDataProductNumberColumn)
wsDataProductNumberColumn = UCase(wsDataProductNumberColumn)
If Len(wsDataProductNumberColumn) > 1 Then
'MsgBox "Product number column must be a single letter, like 'A' !"
MsgBox "產品編號欄位必須是一個英文字母, 例如: 'A' !"
Exit Sub
End If
If Asc(wsDataProductNumberColumn) < 65 Or Asc(wsDataProductNumberColumn) > 90 Then
' MsgBox "Product number column must be between columns A and Z (A-Z) !"
MsgBox "產品編號欄位必須在 A 到 Z 之間"
Exit Sub
End If

' Ask the user "What is Product picture column?" !
' wsDataProductPictureColumn = InputBox("Please enter column letter where product pictures should be stored" + vbCrLf + "For example: B", "Product picture column")
wsDataProductPictureColumn = InputBox("圖片要放在哪一欄?" + vbCrLf + "例如: B", "圖片欄位")

' Check if user inputted anything in product picture column !
If wsDataProductPictureColumn = "" Then
' MsgBox "Product picture column must be provided, please enter it and run macro again!"
MsgBox "沒有輸入圖片欄位沒法置入圖片, 再見"
Exit Sub
End If

' Check if provided answer for product picture column is an actual column letter !
wsDataProductPictureColumn = Trim(wsDataProductPictureColumn)
wsDataProductPictureColumn = UCase(wsDataProductPictureColumn)
If Len(wsDataProductPictureColumn) > 1 Then
' MsgBox "Product picture column must be a single letter, like 'B' !"
MsgBox "圖片欄位必須是一個英文字母, 例如: 'B' !"
Exit Sub
End If
If Asc(wsDataProductPictureColumn) < 65 Or Asc(wsDataProductPictureColumn) > 90 Then
' MsgBox "Product picture column must be between columns A and Z (A-Z) !"
MsgBox "圖片欄位必須在 A 到 Z 之間"
Exit Sub
End If
If wsDataProductPictureColumn = wsDataProductNumberColumn Then
' MsgBox "Provided product number column and product picture columns are the same, please type different columns and run macro again!"
MsgBox "產品編號的欄位跟放圖片的欄位不能在一個, 請重來, 再見"
Exit Sub
End If
' --------------------------------------------------------------------------------------------

' --------------------------------------------------------------------------------------------
' ----------------------------------- PROCESSING ! -------------------------------------------
' --------------------------------------------------------------------------------------------

' Create wider product picture column !
wsData.Columns(CStr(wsDataProductPictureColumn) + ":" + CStr(wsDataProductPictureColumn)).ColumnWidth = 15

' Import pictures !
For i = wsDataStartingRow To wsDataEndingRow

wsDataProductNumber = Trim(wsData.Range(wsDataProductNumberColumn + CStr(i)).Value2)

' Skip all rows where product number is empty !
If wsDataProductNumber <> "" Then

' Change the row height to 64px !
wsData.Range(wsDataProductPictureColumn + CStr(i)).RowHeight = 48

' Generate the product picture file path !
wsDataProductPicturePath = picturesFolderPath + Application.PathSeparator + wsDataProductNumber + ".jpg"

' Check if generated product picture file path exists and if it does, import the picture and center it !
If fso.FileExists(wsDataProductPicturePath) Then
Set importPicture = wsData.Range(wsDataProductPictureColumn + CStr(i)).Parent.Pictures.Insert(wsDataProductPicturePath)
importPicture.Top = wsData.Range(wsDataProductPictureColumn + CStr(i)).Top
importPicture.Left = wsData.Range(wsDataProductPictureColumn + CStr(i)).Left + wsData.Range(wsDataProductPictureColumn + CStr(i)).Width / 2 - importPicture.Width / 2
End If

End If

Next i

Application.ScreenUpdating = True

End Sub

搜尋相關Tags的文章: [ excel ] ,
本篇文章發表於2017-11-06 15:30
別忘捐VP感謝幫助你的人 新手會員瞧一瞧
目前尚無任何回覆
   

回覆
如要回應,請先登入.