- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-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
|
|
發表於 2018-6-13 08:26
| 