返回列表 上一主題 發帖

有大大有Excel 2010或2016年版 可以幫忙測試修改這VBA 表單的程式碼嗎?

有大大有Excel 2010或2016年版 可以幫忙測試修改這VBA 表單的程式碼嗎?

本帖最後由 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

可以請問坂大 GBKEE 嗎?  這是很久以前您幫忙寫的VBA ,但2010及2016 Excel 版VBA 表單都跑不出來了。 ...
jeffrey628litw 發表於 2019-5-22 13:49



    請問用 EXCEL 2010以上版本開啟VBA表單會變成抓不出圖案:如下圖
2010 VBA 球員卡圖片檔案表單抓不到資料.jpg
2019-10-16 16:05


請問這是要改這以下嗎?:(我爬文的)

2016版 設定  myCN.Provider = "Microsoft.Jet.OLEDB.4.0"   
可查看 https://social.msdn.microsoft.co ... b40-32bit-and-64bit
我最高版本2010 設為   .Provider = "Microsoft.ACE.OLEDB.12.0"

TOP

        靜思自在 : 世上有兩件事不能等:一、孝順 二、行善。
返回列表 上一主題