麻辣家族討論版版 - Powered by Discuz! Board

標題: 請問我這VBA哪裡有問題？為什麼會無法出現 424 無法找到物件呢? [打印本頁]

作者: jeffrey628litw 時間: 2018-6-12 19:36 標題: 請問我這VBA哪裡有問題？為什麼會無法出現 424 無法找到物件呢?

請問各位前輩先進

如何讓這檔案    [attach]28825[/attach]       可以像右邊這檔案開啟圖檔呢? [attach]28824[/attach]

   右邊的檔案圖片如下：

[attach]28826[/attach]

請問我這VBA哪裡有問題？為什麼會無法出現 424 無法找到物件呢?

Private Sub ComboBox1_Change()
Dim a As Range
Application.ScreenUpdating = False
With Database
  Set a = .Columns("E").Find(ComboBox1, lookat:=xlWhole)
  Label1.Caption = a.Offset(, 1)
  a.Offset(, 1).CopyPicture '複製成圖片 a.Offset(, 1).  1為傳回上1行程式 a = .Columns("E").後1格儲存格的圖片
  With .ChartObjects.Add(1, 1, a.Offset(, 2).Width, a.Offset(, 2).Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export "D:\temp.jpg" '匯出圖表，暫存圖片
.Delete '刪除圖表
  End With
  Image1.Picture = LoadPicture("D:\temp.jpg") '表單顯示圖片
  Kill "D:\temp.jpg" '刪除暫存圖片
End With
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
Dim a As Range
Set d = CreateObject("Scripting.Dictionary")
With Database
For Each a In .Range(.[E2], .[E2].End(xlDown))
   d(a.Value) = ""
Next
End With
ComboBox1.List = d.keys
End Sub

-------------------------------------------------------------------
謝謝各位

作者: GBKEE 時間: 2018-6-13 08:26

本帖最後由 GBKEE 於 2018-6-13 08:27 編輯

回復 1# jeffrey628litw

試試看

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
Dim D As Object, Sh As Worksheet '模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Private Sub UserForm_Initialize()
Dim A As Range, S As String
Set D = CreateObject("Scripting.Dictionary")
Set Sh = Sheets("Database") '工作表如有變動時在此修改即可
'With Sheets("Database") ' 或是 With Sheet1
With Sh
For Each A In .Range(.[E2], .[E2].End(xlDown))
'**************************
'F10 ,F11 有換行字元需修改
'大谷翔平
'Shohei Ohtan
'***************************
S = Replace(Trim(A), vbLf, Space(1)) '換行字元改成 Space(1)
Set D(S) = Range(A.Offset(, 1).Address)
'Debug.Print S, D(S).Address '指令:檢視->及時視窗可看看
Next
End With
ComboBox1.List = D.keys
Label1.WordWrap = False '內容在行末是否自動換行
With Image1 '設定圖片的顯示設模式
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
End Sub
Private Sub ComboBox1_Change()
Dim A As Range
Label1.Caption = "沒有此圖片"
Image1.Picture = LoadPicture("") '不顯示圖片
'Image1.Visible = False '或是隱藏
If ComboBox1.ListIndex = -1 Then Exit Sub
If 圖片檢查(D(ComboBox1.Value).Address) = False Then Exit Sub
'Image1.Visible = True '顯示
End Sub
Private Function 圖片檢查(xPicture As String) As Boolean
Dim S As Shape, P As Object, xTop As Double
For Each S In Sh.Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
圖片檢查 = True
S.Copy '圖片複製
Set P = S
Exit For
End If
'***************************************************
Next
If 圖片檢查 = True Then
With Sh
Label1.Caption = ComboBox1
With .ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export "D:\temp.jpg" '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
Image1.Picture = LoadPicture("D:\temp.jpg") '表單顯示圖片
Kill "D:\temp.jpg" '刪除暫存圖片
End With
End If

複製代碼

作者: jeffrey628litw 時間: 2018-6-13 14:11

回復 2# GBKEE

謝謝 G 超級版主的回覆，目前發現最後要加 End Function 就可以Run了，其他還在研究中，超級感謝您的幫忙。

作者: jeffrey628litw 時間: 2018-6-13 22:26

回復 jeffrey628litw

試試看
GBKEE 發表於 2018-6-13 08:26

請問我想要按Display Photo按鈕後，
下拉選單 Player Name
   選Mchael  Jordan 後可以出現
   Image1：為F2圖案
   Image2為F3圖案

   類似EBAY 篩選完有陣列圖表，類似下圖

[attach]28832[/attach]

檔案在雲端  http://webhd.xuite.net/_oops/jeffrey628litw/c6x

作者: GBKEE 時間: 2018-6-15 09:31

回復 4# jeffrey628litw
試試看

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
Dim D As Object, Sh(1 To 2) As Worksheet '模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Dim xTempPicture As String
Private Sub UserForm_Initialize()
Dim A As Range, S As String
Set D = CreateObject("Scripting.Dictionary")
Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
Set Sh(2) = ThisWorkbook.Sheets.Add
xTempPicture = "D:\IE.jpg"
匯入圖片 '載入表單畫面圖片
With Sh(1)
For Each A In .Range(.[E2], .[E2].End(xlDown))
'**************************
'F10 ,F11 有換行字元需修改
'大谷翔平
'Shohei Ohtan
'***************************
S = Replace(Trim(A), vbLf, Space(1)) '換行字元改成 Space(1)
Set D(S) = Range(A.Offset(, 1).Address)
'Debug.Print S, D(S).Address '指令:檢視->及時視窗可看看
Next
End With
ComboBox1.List = D.KEYS
Label1.WordWrap = False '內容在行末是否自動換行
With Image1 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
With Image2 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(2).Delete
Kill xTempPicture
Application.DisplayAlerts = True
End Sub
Private Sub ComboBox1_Change()
Dim A As Range
Label1.Caption = "沒有此圖片"
Image1.Picture = LoadPicture(xTempPicture) '表單預設的圖片
Image2.Picture = LoadPicture(xTempPicture) '表單預設的圖片
'Image1.Visible = False '或是隱藏
With ComboBox1
If .ListIndex = -1 Then Exit Sub
圖片檢查 D(.List(.ListIndex)).Address, Image1
If 圖片檢查(D(.Value).Address, Image1) Then Label1.Caption = ComboBox1
If .ListIndex < .ListCount - 1 Then 圖片檢查 D(.List(.ListIndex + 1)).Address, Image2
End With
End Sub
Private Function 圖片檢查(xPicture As String, xImage As Image) As Boolean
Dim S As Shape, P As Object, xName As String
For Each S In Sh(1).Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
圖片檢查 = True
Set P = S '.Copy '圖片複製
Exit For
End If
'***************************************************
Next
If 圖片檢查 = True Then
xName = "D:\temp.jpg"
照片Export P, xName
xImage.Picture = LoadPicture(xName) '表單顯示圖片
Kill xName ' "D:\temp.jpg" '刪除暫存圖片
End If
End Function
Private Sub 照片Export(P As Object, xName As String)
P.Copy
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xName '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub
Sub 匯入圖片()
Dim P As Picture
With Sh(2)
Set P = .Pictures.Insert("http://forum.twbts.com/templates/discuz6/images/logotop.png") '(工作表上插入照片)
With [a1] '指定的儲存格
P.Top = .Top '照片的右方在工作表上的位置
P.Left = .Left '照片的右方在工作表上的位置
.RowHeight = IIf(P.Height >= 409, 409, P.Height) '調整儲存格高度=>照片的高度
P.Height = IIf(P.Height >= 409, 409, P.Height) '調整儲存格高度=>照片的高度
If .Width < P.Width * (.ColumnWidth / .Width) Then '下載照片的最大寬度
.Width = P.Width * (.ColumnWidth / .Width)
.ColumnWidth = P.Width * (.ColumnWidth / .Width) '調整儲存格欄寬=>照片的寬度
End If
End With
End With
照片Export P, xTempPicture
End Sub

複製代碼

作者: jeffrey628litw 時間: 2018-6-15 13:32

本帖最後由 jeffrey628litw 於 2018-6-15 13:45 編輯

回復 5# GBKEE

超級版主您好：
我發現有3個問題，要麻煩您，問題如下：
1. 問題1.
預設圖案撈 F1儲存格圖案 (或者您這裡可以寫成預設圖片是Null)
[attach]28839[/attach]

2. 問題2.
撈的名字正確的圖案會出來，但會多撈下1欄圖片，沒有資料的應該撈的圖是F1儲存格的沒有圖片 (如果問題1您寫成預設圖片是Null那就不用撈F1儲存格)
[attach]28840[/attach]

3. 問題3.
撈同名字時例如大谷翔平，撈不出同樣名字但不同圖片

現狀：
[attach]28841[/attach]
希望改善成Combobox1 (即下拉 Players Name)撈同名字時能撈出不同圖，如下圖：
[attach]28842[/attach]

補充圖片給您放入F1儲存格或者寫程式路徑抓圖用：[attach]28843[/attach]

檔案在雲端：http://webhd.xuite.net/_oops/jeffrey628litw/l0e

作者: GBKEE 時間: 2018-6-15 16:39

回復 6# jeffrey628litw
再試試

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
Dim Sh(1 To 2) As Worksheet, xTempPicture As String '模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Private Sub UserForm_Initialize()
Dim A As Range, i As Integer
Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
Set Sh(2) = ThisWorkbook.Sheets.Add
匯入圖片 '置入"沒有圖片"檔
'不要用字典物件 Set D = CreateObject("Scripting.Dictionary")
With ComboBox1
For Each A In Sh(1).Range(Sh(1).[E3], Sh(1).[E3].End(xlDown))
'ColumnCount 屬性若將 ColumnCount 設成 0，顯示的行數便是 0；若設成 -1，便顯示所有的資料行。對一個非資料連結的資料來源而言，最多只能有 10 行 (0 到 9)。
.ColumnCount = 2 '了解後,可不用此行程式碼?
.AddItem
.List(.ListCount - 1, 0) = A
.List(.ListCount - 1, 1) = A.Offset(, 1).Address
Next
End With
Label1.WordWrap = False '內容在行末是否自動換行
Label4.WordWrap = False '*******新增Label控制項
With Image1 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
With Image2 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(2).Delete
Kill xTempPicture
Application.DisplayAlerts = True
End Sub
Private Sub ComboBox1_Change()
Dim A As Range
Label1.Caption = "沒有此圖片"
Label4.Caption = "沒有此圖片" '*******新增Label控制項
Image1.Picture = LoadPicture(xTempPicture) '表單預設的圖片
Image2.Picture = LoadPicture(xTempPicture) '表單預設的圖片
With ComboBox1
If .ListIndex = -1 Then Exit Sub
If 圖片檢查(.List(.ListIndex, 1), Image1) = True Then Label1.Caption = .Value
If .ListIndex < .ListCount - 1 Then
If 圖片檢查(.List(.ListIndex + 1, 1), Image2) Then Label4.Caption = .List(.ListIndex + 1, 0)
'*******新增Label控制項
End If
End With
End Sub
Private Function 圖片檢查(xPicture As String, xImage As Image) As Boolean
Dim S As Shape, P As Object, xName As String
For Each S In Sh(1).Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
圖片檢查 = True
Set P = S '.Copy '圖片複製
Exit For
End If
'***************************************************
Next
If 圖片檢查 = True Then
xName = "D:\temp.jpg"
照片Export P, xName
xImage.Picture = LoadPicture(xName) '表單顯示圖片
Kill xName ' "D:\temp.jpg" '刪除暫存圖片
End If
End Function
Private Sub 照片Export(P As Object, xName As String)
P.Copy
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xName '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub
Sub 匯入圖片()
Dim P As Range
xTempPicture = "D:\NoPicture.jpg"
Set P = Sh(1).[f2]
P.CopyPicture
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xTempPicture '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub

複製代碼

作者: jeffrey628litw 時間: 2018-6-15 18:31

回復 7# GBKEE

G大超級版主您好，我看您已經有將我問題1解決了，另外要程式中說明要新增 Lable4 我也新增了，

問題2和3還沒解決，

接下來，
程式的邏輯是要依據撈出的Lable4 如果結果同Lable1的字串，則撈出圖片，否則撈出Null的圖片嗎?

是這樣的話請問要如何寫呢? 因為我對於VBA實在幾乎完全不了解，能否請您幫忙一點一點解給我看，我慢慢學呢?
謝謝您。

檔案在雲端：http://webhd.xuite.net/_oops/jeffrey628litw/wyh

作者: GBKEE 時間: 2018-6-16 06:22

本帖最後由 GBKEE 於 2018-6-16 06:26 編輯

回復 8# jeffrey628litw
對於VBA不了解,可多看看論壇的主題及VBA上說明,並多練習,會進步的
不懂可提問.內容讓人看懂就會得到回覆(義務性)

如有不符,請再詳加說明

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
Dim Sh(1 To 2) As Worksheet, D As Object, xTempPicture As String '模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Private Sub UserForm_Initialize()
Dim A As Range, S As String
Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
Set Sh(2) = ThisWorkbook.Sheets.Add
xTempPicture = "D:\NoPicture.jpg"
照片Export Sh(1).Range("F2"), xTempPicture '置入"沒有圖片"檔
Set D = CreateObject("Scripting.Dictionary")
For Each A In Sh(1).Range(Sh(1).[E3], Sh(1).[E3].End(xlDown))
S = Replace(Trim(A), vbLf, Space(1)) '換行字元改成 Space(1)
If D.EXISTS(S) Then
D(S) = D(S) & "," & A.Offset(, 1).Address
Else
D(S) = A.Offset(, 1).Address
End If
Next
ComboBox1.List = D.KEYS
Label1.WordWrap = False '內容在行末是否自動換行
Label4.WordWrap = False '*******新增Label控制項
With Image1 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
With Image2 '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter '2
.PictureSizeMode = fmPictureSizeModeClip '0
End With
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(2).Delete
Kill xTempPicture
Application.DisplayAlerts = True
End Sub
Private Sub ComboBox1_Change()
Dim A As Variant, i As Integer, S As String
Label1.Caption = "沒有此圖片"
Label4.Caption = "沒有此圖片" '*******新增Label控制項
Image1.Picture = LoadPicture(xTempPicture) '表單預設的圖片
Image2.Picture = LoadPicture(xTempPicture) '表單預設的圖片
With ComboBox1
If .ListIndex = -1 Then Exit Sub
A = Split(D(.Value), ",")
For i = 0 To 1
If i <= UBound(A) Then
S = A(i)
If 圖片檢查(S, IIf(i = 0, Image1, Image2)) Then Label1.Caption = .Value
End If
Next
Label4.Visible = UBound(A) = 0 '有相同的 Player Name 則不顯示
If UBound(A) = 0 And .ListIndex < .ListCount - 1 Then
A = Split(D(.List(.ListIndex + 1)), ",")
S = A(0)
If 圖片檢查(S, Image2) Then Label4.Caption = .List(.ListIndex + 1, 0)
'*******新增Label控制項
End If
End With
End Sub
Private Function 圖片檢查(xPicture As String, xImage As Image) As Boolean
Dim S As Shape, xName As String
For Each S In Sh(1).Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
圖片檢查 = True
Exit For
End If
'***************************************************
Next
If 圖片檢查 = True Then
xName = "D:\temp.jpg"
照片Export S, xName
xImage.Picture = LoadPicture(xName) '表單顯示圖片
Kill xName ' "D:\temp.jpg" '刪除暫存圖片
End If
End Function
Private Sub 照片Export(P As Object, xName As String)
If xName <> "D:\temp.jpg" Then
P.CopyPicture
Else
P.Copy
End If
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xName '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub

複製代碼

作者: jeffrey628litw 時間: 2018-6-16 11:22

回復 9# GBKEE

G大版主您好：我看了問題3也解決了，剩下問題2，這邏輯是要寫

當Lable1 And Lable4 不為空時且不相同，則顯示2張圖片到Image1 和Image4，
否則當Lable1不等於 Label4，則顯示Image1 且 Image4為空
否則當Label1等於空，Lable4不等於空，則顯示Image1為空且顯示 Image4的圖片

是這樣子嗎? 是的話程式要怎麼寫呢?再請您賜教，謝謝。

雲端檔案：http://webhd.xuite.net/_oops/jeffrey628litw/gdn

作者: GBKEE 時間: 2018-6-17 10:50

本帖最後由 GBKEE 於 2018-6-17 11:04 編輯

回復 10# jeffrey628litw

2. 問題2.
撈的名字正確的圖案會出來，但會多撈下1欄圖片，沒有資料的應該撈的圖是F1儲存格的沒有圖片 (如果問題1您寫成預設圖片是Null那就不用撈F1儲存格)
這是 6#中的提問
我理解是ComboBox1所選的名字有圖案時顯視在Image1,沒有圖案時Image1成預設圖片(給的程式是這樣寫沒錯)

關於Image2 這程式碼條件成立時才處理(這是我多做的處理嗎?)

If UBound(A) = 0 And .ListIndex < .ListCount - 1 Then

複製代碼

UBound(A) = 0 **ComboBox1所選的名字在Database中是一的名字**
.ListIndex < .ListCount - 1 **所選的名字在ComboBox1的list中不是最後一個value(值)名字
將下個名字的圖片顯視在Image2

如不處理則開頭就處理了

Private Sub ComboBox1_Change()
Dim A As Variant, i As Integer, S As String
Label1.Caption = "沒有此圖片"
Label4.Caption = "沒有此圖片" '*******新增Label控制項
Image1.Picture = LoadPicture(xTempPicture) '表單預設的圖片
Image2.Picture = LoadPicture(xTempPicture) '表單預設的圖片

複製代碼

*****************************
3. 問題3.
撈同名字時例如大谷翔平，撈不出同樣名字但不同圖片,希望改善成Combobox1 (即下拉 Players Name)撈同名字時能撈出不同圖
UBound(A) > 0時-> **ComboBox1所選的名字在Database不是一的名字**

A = Split(D(.Value), ",")
For i = 0 To 1
If i <= UBound(A) Then
S = A(i)
If 圖片檢查(S, IIf(i = 0, Image1, Image2)) Then Label1.Caption = .Value
End If
Next

複製代碼

作者: jeffrey628litw 時間: 2018-6-17 11:36

回復 11# GBKEE

G大版主您好：對於問題2 我有照您說的將哪一段程式隱藏就不會將沒有的資料對應的圖片，撈出下一張圖片了。
是我之前沒有跟您說清楚。

這樣就全部解決了我的問題了，很感謝您這麼有耐心地回覆我的問題，再次感謝您。

作者: jeffrey628litw 時間: 2018-6-18 09:43

本帖最後由 jeffrey628litw 於 2018-6-18 09:46 編輯

回復 11# GBKEE

G大版大您好：我有自己改成可以撈4個圖片的檔案，如今有新的問題：
1.顯示圖片可以自動調整圖片大小在框框內：將Display Each Player Photo 這按鈕顯示的白色框框內圖片可以
自動顯示和 After Sieve Display Photo 白色框框內圖片自動調整大小及位置

[attach]28862[/attach] 改成-->[attach]28861[/attach] 同大小及位置

2.想要顯示圖片資料，以便超連結到Database 工作表，(不知是否用Textbox，是的話要如何寫VBA呢?)
1.希望將工作表Database 裡面將E欄對應B欄的資料撈出來，
到Textbox，
例如E3撈出B3到Textbox1
2.然後讓Database的文字超連結到工作表 Database

檔案雲端連結：http://webhd.xuite.net/_oops/jeffrey628litw/u05

謝謝版大的幫忙。

作者: jeffrey628litw 時間: 2018-6-18 10:04

回復 13# jeffrey628litw

這個問題下面寫錯，應該是
2.想要顯示圖片資料，以便超連結到Database 工作表，(不知是否用Textbox，是的話要如何寫VBA呢?)
1.希望將工作表Database 裡面將E欄對應B欄的資料撈出來，
到Textbox，
例如E3撈出B3到Textbox1
2.然後讓Textbox的文字超連結到工作表 Database

[attach]28863[/attach]

作者: GBKEE 時間: 2018-6-18 12:15

本帖最後由 GBKEE 於 2018-6-20 09:01 編輯

回復 14# jeffrey628litw
試試看

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
Dim Sh(1 To 2) As Worksheet, D As Object, xTempPicture As String '模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Dim AR_Image(), AR_TexTbox(), AR_Label(), xName As String
Private Sub UserForm_Initialize()
Dim A As Range, S As String, E As Variant
Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
Set Sh(2) = ThisWorkbook.Sheets.Add
AR_Image = Array(Image1, Image2, Image3, Image4)
AR_TexTbox = Array(TextBox1, TextBox2, TextBox3, TextBox4)
AR_Label = Array(Label1, Label4, Label6, Label8)
xTempPicture = "D:\NoPicture.jpg"
xName = "D:\temp.jpg"
照片Export Sh(1).Range("F2"), xTempPicture '置入"沒有圖片"檔當作預設圖片及沒有圖片
Set D = CreateObject("Scripting.Dictionary")
For Each A In Sh(1).Range(Sh(1).[E3], Sh(1).[E3].End(xlDown))
S = Replace(Trim(A), vbLf, Space(1)) '換行字元改成 Space(1)
If D.EXISTS(S) Then
D(S) = D(S) & "," & A.Offset(, 1).Address
Else
D(S) = A.Offset(, 1).Address
End If
Next
ComboBox1.List = D.KEYS
For E = 0 To UBound(AR_Image)
With AR_Image(E) '設定圖片的顯示設模式
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter ' *** 0,1,2,3,4
.PictureSizeMode = 3 'fmPictureSizeModeClip ' *** 0,1,3
'***** 請自行調整******
'**1.顯示圖片可以自動調整圖片大小在框框內：將Display Each Player Photo 這按鈕顯示的白色框框內圖片可以
'***自動顯示和 After Sieve Display Photo 白色框框內圖片自動調整大小及位置
End With
AR_TexTbox(E).MultiLine = True '指定控制項是否接受並顯示多行文字。
AR_Label(E).WordWrap = False '內容在行末是否自動換行
Next
End Sub
'***********************************************************************************
'以下為開啟UserForm1時會自動開啟1工作表，有以下程式在關閉UserForm1時會自動關閉工作表
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(2).Delete
Kill xTempPicture
Kill xName ' "D:\temp.jpg" '刪除暫存圖片
Application.DisplayAlerts = True
End Sub
'***********************************************************************************
Private Sub ComboBox1_Change()
Dim A As Variant, i As Integer, S As String, ii As Integer
For i = 0 To UBound(AR_Label)
AR_Label(i).Caption = "沒有此圖片"
AR_TexTbox(i).Text = ""
AR_Image(i).Picture = LoadPicture(xTempPicture) '表單預設的圖片為 Databasse 工作表中的 F3 儲存格圖片
Next
With ComboBox1
If .ListIndex = -1 Then Exit Sub
A = Split(D(.Value), ",")
For i = 0 To 3 '如要增加或減少圖片則修改 i = 0 To 3 後面的3的數量
If i <= UBound(A) Then
S = A(i)
If 圖片檢查(S) Then '
AR_Image(ii).Picture = LoadPicture(xName)
AR_Label(ii).Caption = Sh(1).Range(S).Offset(, -1).Text
AR_TexTbox(ii).Text = Sh(1).Range(S).Offset(, -4).Text
ii = ii + 1
End If
End If
Next
End With
End Sub
Private Function 圖片檢查(xPicture As String) As Boolean
Dim S As Shape
For Each S In Sh(1).Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
圖片檢查 = True
Exit For
End If
'***************************************************
Next
If 圖片檢查 = True Then 照片Export S, xName
End Function
Private Sub 照片Export(P As Object, xName As String)
If xName <> "D:\temp.jpg" Then
P.CopyPicture
Else
P.Copy
End If
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xName '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub

複製代碼

作者: jeffrey628litw 時間: 2018-6-18 14:25

回復 15# GBKEE

G大版主您好：出現下面的情況，我查不到如何解?

[attach]28864[/attach]

作者: GBKEE 時間: 2018-6-18 15:16

回復 16# jeffrey628litw

查看這程序上的程式碼有無缺失掉

Private Sub 照片Export(P As Object, xName As String)

複製代碼

作者: jeffrey628litw 時間: 2018-6-19 15:25

回復 17# GBKEE

G大版主您好：我整理好檔案了，已經符合我的想法了，非常感謝您的大力幫忙，我也將檔案放在這裡分享，再次感謝。

雲端檔案分享：http://webhd.xuite.net/_oops/jeffrey628litw/uxz

作者: GBKEE 時間: 2018-6-20 09:06

回復 18# jeffrey628litw
[14] 大谷翔平 Shohei Ohtani球棒卡球棒頂端 F15 沒有圖片
所以修改 15#的程式碼,會更為貼切

作者: jeffrey628litw 時間: 2018-6-20 16:26

回復 19# GBKEE

G大版主您好：我不懂您的意思，我F15儲存格是故意不放圖片要測試撈不撈的出預設的圖片(沒有圖片)

作者: GBKEE 時間: 2018-6-20 19:04

回復 20# jeffrey628litw

F15儲存格是故意不放圖片要測試撈不撈的出預設的圖片(沒有圖片)
那圖片就依續放在Image1, Image2,Image3,Image4 中 Image3 是沒有圖片的

修改後是將三個有圖片連續放在Image1, Image2,Image3 ,Image4 是沒有圖片的

作者: jeffrey628litw 時間: 2018-6-20 23:55

回復 21# GBKEE

G大  版主您好：
1.就依照您說的方式，可以幫我那樣改嗎?

   然後我又有2個問題需要您幫忙我：

2.
   2-1.可以新增1個Combobox2 ，然後篩選工作表 Datababse "J欄"不重複資料，例如 BGS、PSA、沒鑑定。
   2-2.然後這個Combobox2可以如果Combox1 篩選名字後，如Michael Jordan,然後再篩選Combobox2選BGS後出現圖片

3.然後因為篩選後會超過4張Image，所以要製作分頁篩選，這可以用Combobox3製作嗎?如圖中右上方所示

[attach]28871[/attach]

雲端檔案：http://webhd.xuite.net/_oops/jeffrey628litw/k03

感謝G大版主。

作者: GBKEE 時間: 2018-6-23 15:23

回復 22# jeffrey628litw
3.然後因為篩選後會超過4張Image
ComboBox1 右邊新增一ComboBox3
ComboBox2 右邊新增一ComboBox4

Option Explicit '強制模組的變數必須要 Dim的宣告,會使程式易於偵錯
'模組頂端上 Dim的變數可在UserForm1的全部程式中使用
Dim Sh(1 To 2) As Worksheet, D As Object, D1 As Object, xTempPicture As String
Dim AR_Image(), AR_TexTbox(), AR_Label(), xName As String
Private Sub UserForm_Initialize()
Dim A As Range, S As String, E As Variant
Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
Set Sh(2) = ThisWorkbook.Sheets.Add
AR_Image = Array(Image1, Image2, Image3, Image4)
AR_TexTbox = Array(TextBox1, TextBox2, TextBox3, TextBox4)
AR_Label = Array(Label1, Label4, Label6, Label8)
xTempPicture = "D:\NoPicture.jpg"
xName = "D:\temp.jpg"
照片Export Sh(1).Range("F2"), xTempPicture '置入"沒有圖片"檔當作預設圖片及沒有圖片
ComboBox設定 ComboBox1, D
For E = 0 To UBound(AR_Image)
With AR_Image(E) '設定圖片的顯示設模式 '***** 請自行調整******
.Picture = LoadPicture(xTempPicture)
.PictureAlignment = fmPictureAlignmentCenter ' *** 0,1,2,3,4
.PictureSizeMode = 3 'fmPictureSizeModeClip ' *** 0,1,3
End With
AR_TexTbox(E).MultiLine = True '指定控制項是否接受並顯示多行文字。
AR_Label(E).WordWrap = False '內容在行末是否自動換行
Next
End Sub
'***********************************************************************************
'以下為開啟UserForm1時會自動開啟1工作表，以下程式在關閉UserForm1時會自動關閉工作表
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
Application.DisplayAlerts = False
Sh(2).Delete
Kill xTempPicture
Kill xName ' "D:\temp.jpg"
Application.DisplayAlerts = True
End Sub
'***********************************************************************************
Private Sub ComboBox1_Change()
Dim A As Variant, i As Integer, S As String, ii As Integer
清圖
With ComboBox1
If .ListIndex = -1 Then ComboBox2.Clear: ComboBox3.Clear: ComboBox4.Clear: Exit Sub
If IsArray(D(.Value)) Then A = D(.Value)(0) Else A = D(.Value)
ComboBox頁設定 ComboBox3, A
ComboBox設定 ComboBox2, D1
If ComboBox3.Enabled Then ComboBox3.ListIndex = 0
End With
End Sub
Private Sub ComboBox2_Change()
Dim A As Variant
With ComboBox2
清圖
If .ListIndex = -1 Then Exit Sub
A = D1(.Value)
If IsArray(D1(.Value)) Then A = D1(.Value)(0) Else A = D1(.Value)
ComboBox頁設定 ComboBox4, A
If ComboBox4.Enabled Then ComboBox4.ListIndex = 0
End With
End Sub
Private Sub ComboBox3_Change()
清圖
ComboBox4.Clear
If ComboBox3.ListIndex > -1 Then 設圖 ComboBox1, ComboBox3, D
End Sub
Private Sub ComboBox4_Change()
清圖
If ComboBox4.ListIndex > -1 Then 設圖 ComboBox2, ComboBox4, D1
End Sub
Private Sub 清圖()
Dim i As Integer
For i = 0 To UBound(AR_Label)
AR_Label(i).Caption = "沒有此圖片"
AR_TexTbox(i).Text = ""
AR_Image(i).Picture = LoadPicture(xTempPicture) '表單預設的圖片為 Databasse 工作表中的 F3 儲存格圖片
Next
End Sub
Private Sub 設圖(ComBo As MSForms.ComBobox, ComBobox As MSForms.ComBobox, D As Object)
Dim P As Object, i As Integer, ii As Integer
With ComBobox
For i = .ListIndex * 4 To (.ListIndex + 1) * 4 - 1
If i <= UBound(D(ComBo.Value)(0)) Then
AR_Label(ii).Caption = D(ComBo.Value)(1)(i)
AR_TexTbox(ii).Text = D(ComBo.Value)(2)(i)
Set P = D(ComBo.Value)(0)(i)
照片Export P, xName
AR_Image(ii).Picture = LoadPicture(xName) '表單顯示圖片
ii = ii + 1
End If
Next
End With
End Sub
Private Sub ComboBox頁設定(ComBo As MSForms.ComBobox, S As Variant)
Dim i As Integer
With ComBo
.Clear
Debug.Print .Name
ComBo.Enabled = IsArray(S)
If Not IsArray(S) Then Exit Sub
For i = 0 To UBound(S) Step 4
.AddItem Int((i + 1) / 4) + IIf(4 Mod (i + 1) >= 0, 1, 0)
Next
End With
End Sub
Private Sub ComboBox設定(ComBo As MSForms.ComBobox, D As Variant)
Dim A As Range, S As String, E As Variant, i As Integer, ii As Integer, iii As Integer, AR, AR1()
Dim xShape As Shape
Set D = CreateObject("Scripting.Dictionary")
For Each A In Sh(1).Range(Sh(1).Range("E3"), Sh(1).Range("E3").End(xlDown))
If ComBo.Name = "ComboBox1" Then
S = Replace(Trim(A), vbLf, Space(1))
Else
If ComboBox1 <> Replace(Trim(A), vbLf, Space(1)) Or Trim(A.Offset(, 5)) = "" Then GoTo Net
S = Replace(Trim(A.Offset(, 5)), vbLf, Space(1)) '換行字元改成 Space(1)
End If
Set xShape = 圖片檢查(A.Offset(, 1).Address)
If Not xShape Is Nothing Then
If D.EXISTS(S) Then
If IsArray(D(S)) Then
AR = D(S)
iii = UBound(AR(0)) + 1
For ii = 0 To UBound(AR)
ReDim AR1(0 To iii)
For i = 0 To UBound(AR1)
If ii = 0 Then If i < UBound(AR1) Then Set AR1(i) = AR(ii)(i) Else Set AR1(i) = xShape
If ii = 1 Then If i < UBound(AR1) Then AR1(i) = AR(ii)(i) Else AR1(i) = A.Text
If ii = 2 Then If i < UBound(AR1) Then AR1(i) = AR(ii)(i) Else AR1(i) = Sh(1).Cells(A.Row, "B").Text
Next
AR(ii) = AR1
Next
D(S) = AR
Else
D(S) = Array(Array(xShape), Array(A.Text), Array(Sh(1).Cells(A.Row, "B").Text))
End If
Else
D(S) = Array(Array(xShape), Array(A.Text), Array(Sh(1).Cells(A.Row, "B").Text))
End If
Else
If Not D.EXISTS(S) Then D(S) = False
End If
Net:
Next
ComBo.Clear
If D.Count > 0 Then ComBo.List = D.KEYS
End Sub
Private Function 圖片檢查(xPicture As String) As Object
Dim S As Shape
Set 圖片檢查 = Nothing
For Each S In Sh(1).Shapes
'*************************************************
'Shape物件是照片且位置是D(ComboBox1.Value).Address)
If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
Set 圖片檢查 = S
Exit For
End If
'***************************************************
Next
End Function
Private Sub 照片Export(P As Object, xName As String)
If xName <> "D:\temp.jpg" Then
P.CopyPicture
Else
P.Copy
End If
With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export xName '匯出圖表，暫存圖片
.Delete '刪除圖表
End With
End Sub

複製代碼

作者: jeffrey628litw 時間: 2018-6-23 15:50

回復 23# GBKEE

G大版大您好：我有試用過新功能了，都可以使用解決了我的問題，真的很感謝您的大力幫忙，我再研究您的程式，
不過如果有新的想法需求，可能還要麻煩您了，再次感謝，我趕快再來研究看看。.....^^......

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)