本帖最後由 jeffrey628litw 於 2019-5-22 13:54 編輯
可以請問坂大 GBKEE 嗎? 這是很久以前您幫忙寫的VBA ，但2010及2016 Excel 版VBA 表單都跑不出來了。
可以請您幫忙測試改程式碼嗎?
檔案下載：http://www.FunP.Net/604675
工作表：Main Query System 裡面的VBA 表單
UserForm1 程式碼如下：
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 |
發表於 2019-5-22 13:49
| 
