GBKEE

回復 10# jeffrey628litw

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

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

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

複製代碼

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

如不處理則開頭就處理了

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

複製代碼

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

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

複製代碼

jeffrey628litw

回復 11# GBKEE


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

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

jeffrey628litw

回復 11# GBKEE


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

下載 (75.21 KB)

2018-6-18 09:40

    改成-->

下載 (47.75 KB)

2018-6-18 09:39

  同大小及位置

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


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

謝謝版大的幫忙。

jeffrey628litw

回復 13# jeffrey628litw


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

下載 (90.87 KB)

2018-6-18 10:04

GBKEE

回復 14# jeffrey628litw
試試看

1. Option Explicit                  '強制 模組的變數必須要 Dim的宣告,會使程式易於偵錯
   
2. Dim Sh(1 To 2) As Worksheet, D As Object, xTempPicture As String  '模組頂端上 Dim的變數 可在UserForm1的全部程式中使用
   
3. Dim AR_Image(), AR_TexTbox(), AR_Label(), xName As String
   
4. Private Sub UserForm_Initialize()
   
5.     Dim A As Range, S As String, E As Variant
   
6.     Set Sh(1) = ThisWorkbook.Sheets("Database") '工作表如有變動時在此修改即可
   
7.     Set Sh(2) = ThisWorkbook.Sheets.Add
   
8.     AR_Image = Array(Image1, Image2, Image3, Image4)
   
9.     AR_TexTbox = Array(TextBox1, TextBox2, TextBox3, TextBox4)
   
10.     AR_Label = Array(Label1, Label4, Label6, Label8)
    
11.     xTempPicture = "D:\NoPicture.jpg"
    
12.     xName = "D:\temp.jpg"
    
13.     照片Export Sh(1).Range("F2"), xTempPicture '置入"沒有圖片"檔 當作預設圖片及沒有圖片
    
14.     Set D = CreateObject("Scripting.Dictionary")
    
15.     For Each A In Sh(1).Range(Sh(1).[E3], Sh(1).[E3].End(xlDown))
    
16.          S = Replace(Trim(A), vbLf, Space(1)) '換行字元 改成 Space(1)
    
17.             If D.EXISTS(S) Then
    
18.                 D(S) = D(S) & "," & A.Offset(, 1).Address
    
19.             Else
    
20.                 D(S) = A.Offset(, 1).Address
    
21.             End If
    
22.     Next
    
23.     ComboBox1.List = D.KEYS
    
24.     For E = 0 To UBound(AR_Image)
    
25.         With AR_Image(E)            '設定圖片的顯示設模式
    
26.             .Picture = LoadPicture(xTempPicture)
    
27.             .PictureAlignment = fmPictureAlignmentCenter ' ***  0,1,2,3,4
    
28.             .PictureSizeMode = 3 'fmPictureSizeModeClip  ' ***  0,1,3
    
29.             '***** 請自行調整******
    
30.             '**1.顯示圖片可以自動調整圖片大小在框框內：將Display Each Player Photo 這按鈕顯示的白色框框內圖片可以
    
31.             '***自動顯示和 After Sieve Display Photo 白色框框內圖片自動調整大小及位置
    
32.         End With
    
33.         AR_TexTbox(E).MultiLine = True   '指定控制項是否接受並顯示多行文字。
    
34.         AR_Label(E).WordWrap = False   '內容在行末是否自動換行
    
35.     Next
    
36. End Sub
    
37. '***********************************************************************************
    
38. '以下為開啟UserForm1時會自動開啟1工作表，有以下程式在關閉UserForm1時會自動關閉工作表
    
39. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
40.     Application.DisplayAlerts = False
    
41.     Sh(2).Delete
    
42.     Kill xTempPicture
    
43.     Kill xName ' "D:\temp.jpg" '刪除暫存圖片
    
44.     Application.DisplayAlerts = True
    
45. End Sub
    
46. '***********************************************************************************
    
47. Private Sub ComboBox1_Change()
    
48.     Dim A As Variant, i As Integer, S As String, ii As Integer
    
49.     For i = 0 To UBound(AR_Label)
    
50.         AR_Label(i).Caption = "沒有此圖片"
    
51.         AR_TexTbox(i).Text = ""
    
52.         AR_Image(i).Picture = LoadPicture(xTempPicture) '表單預設的圖片 為 Databasse 工作表中的 F3 儲存格圖片
    
53.     Next
    
54.     With ComboBox1
    
55.         If .ListIndex = -1 Then Exit Sub
    
56.         A = Split(D(.Value), ",")
    
57.         For i = 0 To 3                    '如要增加或減少圖片則 修改 i = 0 To 3 後面的3的數量
    
58.             If i <= UBound(A) Then
    
59.                 S = A(i)
    
60.                 If 圖片檢查(S) Then '
    
61.                     AR_Image(ii).Picture = LoadPicture(xName)
    
62.                     AR_Label(ii).Caption = Sh(1).Range(S).Offset(, -1).Text
    
63.                     AR_TexTbox(ii).Text = Sh(1).Range(S).Offset(, -4).Text
    
64.                     ii = ii + 1
    
65.                 End If
    
66.             End If
    
67.         Next
    
68.     End With
    
69. End Sub
    
70. Private Function 圖片檢查(xPicture As String) As Boolean
    
71.     Dim S As Shape
    
72.     For Each S In Sh(1).Shapes
    
73.         '*************************************************
    
74.         'Shape物件是照片且位置是D(ComboBox1.Value).Address)
    
75.         If S.Type = msoPicture And S.TopLeftCell.Address = xPicture Then
    
76.             圖片檢查 = True
    
77.             Exit For
    
78.         End If
    
79.         '***************************************************
    
80.     Next
    
81.     If 圖片檢查 = True Then 照片Export S, xName
    
82.    
    
83. End Function
    
84. 
    
85. Private Sub 照片Export(P As Object, xName As String)
    
86.     If xName <> "D:\temp.jpg" Then
    
87.         P.CopyPicture
    
88.     Else
    
89.         P.Copy
    
90.     End If
    
91.     With Sh(2).ChartObjects.Add(1, 1, P.Width, P.Height) '新增圖表
    
92.         .Chart.Paste '貼上圖片
    
93.         .Chart.Export xName '匯出圖表，暫存圖片
    
94.         .Delete '刪除圖表
    
95.      End With
    
96. End Sub

複製代碼

jeffrey628litw

回復 15# GBKEE


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

下載 (88.82 KB)

2018-6-18 14:25

GBKEE

回復 16# jeffrey628litw

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

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

複製代碼

jeffrey628litw

回復 17# GBKEE


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

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

GBKEE

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

jeffrey628litw

回復 19# GBKEE


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