返回列表 上一主題 發帖

一個查詢的表單,

回復 9# GBKEE
GBKEE版大, 好  先行謝過版大回應, 但出現下列問題,
程式貼到檔案工作上, 從下拉選擇編號後,      (  For Each Sp In .Pictures             '尋找N欄中的圖片,複製之 ), 這行顯示黃色,   到底問題在於哪裡, 希望大大能協助, 謝謝

    Private Sub ComboBox1_Change()

    Dim Sp As Picture, I As Integer, R As Integer

    If ComboBox1.ListIndex > -1 Then                    '選擇 ComboBox1的內容

        R = ComboBox1.List(ComboBox1.ListIndex, 1)      'ComboBox第2欄 : 列號 1....

        For I = 0 To UBound(Ar)

            If I <> UBound(Ar) Then

                Ar(I).Text = Sh.Cells(編號 + R, I + 2)  '列號 : 編號 + R

            Else

                '2, 在第11個TextBox11物件中, 可否做到把sheet1第11欄及12欄合拼顯示,如123aaa

                 Ar(I).Text = Sh.Cells(編號 + R, I + 2) & Sh.Cells(編號 + R, I + 3)

             End If

        Next

    End If

    With Sh

        For Each Sp In .Pictures             '尋找N欄中的圖片,複製之

            If Sp.TopLeftCell.Address(0, 0) = "N" & 編號 + R Then Sp.Copy: Exit For

        Next

        '利用圖表匯出存檔

        With .ChartObjects.Add(1, 1, Sp.Width, Sp.Height)           '新增 圖表

             .Chart.Paste                                           '貼上 圖片

             .Chart.Export Filename:=ThePicture                     '匯出 圖片

             .Delete                                                '刪除 圖表

        End With

    End With

    Image1.Picture = LoadPicture(ThePicture)                         'Image1 指定圖片

End Sub
hong912

TOP

回復 11# hong912

試試看下列程式碼
  1. Dim PicAr() As Picture '圖片陣列
  2. Private Const fs = "E:\temp.jpg" '暫存圖片目錄位置
  3. Private Const r = 4 '資料起始列號
  4. Private Sub ComboBox1_Change() '選擇編號事件
  5. Dim k%, i%
  6. With ComboBox1
  7. k = .ListIndex '下拉選單選取位置
  8. For i = 1 To 11
  9.    Controls("TextBox" & i).Text = IIf(i = 11, .List(k, i) & .List(k, i + 1), .List(k, i)) '文字方塊寫入
  10. Next
  11. End With
  12. PicAr(k).CopyPicture '複製圖片
  13. With Sheet1.ChartObjects.Add(, , PicAr(k).Width, PicAr(k).Height) '新增圖表
  14. .Chart.Paste '貼上圖片
  15. .Chart.Export fs '以圖表匯成圖片
  16. Image1.Picture = LoadPicture(fs) '載入圖片
  17. .Delete '刪除圖表
  18. End With
  19. End Sub


  20. Private Sub UserForm_Initialize() '表單初始化
  21. Dim Pic As Picture
  22. With Sheet1
  23. ReDim PicAr(.Pictures.Count)
  24. For Each Pic In .Pictures '將每個圖片置入陣列
  25.   Set PicAr(Pic.TopLeftCell.Row - r) = Pic
  26. Next
  27. ComboBox1.List = .Range("A4", .[A4].End(xlDown).Offset(, 12)).Value '下拉清單內容
  28. End With
  29. Image1.PictureSizeMode = fmPictureSizeModeStretch '圖片載入的型態
  30. End Sub

  31. Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '關閉表單
  32. If Dir(fs) <> "" Then Kill fs '刪除暫存圖片檔案
  33. End Sub
複製代碼
表單圖片查詢.rar (1.28 MB)
學海無涯_不恥下問

TOP

回復 12# Hsieh

Hsieh版大, 早晨
謝謝回應, 一早起床, 看到回應, 的確很高興, 但趕開工, 時間迫切, 要到夜晚才能試用, 感謝回應, 祝願快樂, 謝謝!!

TOP

回復 12# Hsieh

可以運行了, 謝謝大大
hong912

TOP

回復 11# hong912
9# 的程式碼, 是依據你7# 附檔修改的,我執行時並沒有你提到的錯誤
請查看你檔案中的圖片是否有移動,離開7# 附檔的位置.

TOP

回復 15# GBKEE
GBKEE版大,
謝謝大大再度提示, 的確最初沒為意最下列儲存格有二列是沒有圖片, 多謝大大提示, 感恩..謝謝!!
hong912

TOP

昨晚試過, 很合用, 先謝過發問的樓主,
在此更向CBKEE及Hsieh两位超級大大致謝, 感謝两位長久的教導, 過去及現在, 令小妹領會了不小,
謝謝謝!!

TOP

GBKEE 版大, 安好
這两天細看大大所寫的程式, 老實說, 只知道是點點, 同時亦發現一個圖片問題,
希望大大能協助, 在大大的程式中是可以運行, 但當遇上一些不支援的圖片格式
如png, 便會彈出下列提示,
執行階段錯誤91, 沒有設定物件變數或with區塊變數,
大大, 可否修改程式至任何圖片格式都可使用,  煩勞大大, 在此先行謝謝謝!!

Option Explicit                            '在模組層次中強迫每個在模組裏的變數都必須明確的宣告。

Private Const 編號 = 3                     '資料庫的欄位列號

Private Const ThePicture = "d:\ttt.gif"    '設立匯出圖片的路徑檔名

Dim Ar(10), Sh As Worksheet
Private Sub UserForm_Initialize()          '表單初始化的預設事件程序

    Dim I As Integer, e As Range

    Set Sh = Sheets("Sheet1")              '資料庫的工作表

    With Sh

        For Each e In .Range("a4", .[a4].End(xlDown))  '指定 ComboBox1的內容

            With ComboBox1                             'ComboBox1.ColumnCount=1 系統預設 顯示1欄資料

               ' .ColumnCount=2                        '可顯示2欄資料

                .AddItem

                'AddItem 方法 在一個單列清單方塊或下拉式清單方塊中加入一個項目。在一個多列清單方塊或下拉式清單方塊中加入一行。

                .List(.ListCount - 1, 0) = e            'ComboBox第1欄 : 字串

                .List(.ListCount - 1, 1) = e.Row - 編號 'ComboBox第2欄 : 列號 1 - ....

            End With

        Next

    End With

    For I = 0 To UBound(Ar)

      Set Ar(I) = Me.Controls("TextBox" & I + 1) '陣列的元素設為TextBox (物件)

    Next

    Image1.PictureSizeMode = fmPictureSizeModeStretch

    '參數fmPictureSizeModeStretch= 1 :調整圖片大小以填滿表單或活頁,此設定會造成圖片的水平與垂直方向比例被扭曲。

End Sub
Private Sub UserForm_Click() '在表單沒有控制項的地方按下滑鼠左鍵的事件

'1當圖片傳回表單,  圖片不清, 可有方辦解決 ':修改顯示背景圖片的方式

   With Image1

       If .PictureSizeMode = fmPictureSizeModeClip Then

           .PictureSizeMode = fmPictureSizeModeStretch

       ElseIf .PictureSizeMode = fmPictureSizeModeStretch Then

           .PictureSizeMode = fmPictureSizeModeZoom

       ElseIf .PictureSizeMode = fmPictureSizeModeZoom Then

           .PictureSizeMode = fmPictureSizeModeClip

       End If

    End With

' [   常                                   數]  [值]  [ 說      明]

'fmPictureSizeModeClip          0    裁掉圖片多出來的部分 ( 預設 )。

'fmPictureSizeModeStretch    1    調整圖片大小以填滿表單或活頁,此設定會造成圖片的水平與垂直方向比例被扭曲。

'fmPictureSizeModeZoom      3     放大圖片,但不扭曲圖片水平與垂直方向的比例。

End Sub
Private Sub ComboBox1_Change()

    Dim Sp As Picture, I As Integer, R As Integer

    If ComboBox1.ListIndex > -1 Then                    '選擇 ComboBox1的內容

        R = ComboBox1.List(ComboBox1.ListIndex, 1)      'ComboBox第2欄 : 列號 1....

        For I = 0 To UBound(Ar)

            If I <> UBound(Ar) Then

                Ar(I).Text = Sh.Cells(編號 + R, I + 2)  '列號 : 編號 + R

            Else

                '2, 在第11個TextBox11物件中, 可否做到把sheet1第11欄及12欄合拼顯示,如123aaa

                 Ar(I).Text = Sh.Cells(編號 + R, I + 2) & Sh.Cells(編號 + R, I + 3)

             End If

        Next

    End If

    With Sh

        For Each Sp In .Pictures             '尋找N欄中的圖片,複製之

            If Sp.TopLeftCell.Address(0, 0) = "N" & 編號 + R Then Sp.Copy: Exit For

        Next

        '利用圖表匯出存檔

        With .ChartObjects.Add(1, 1, Sp.Width, Sp.Height)           '新增 圖表

             .Chart.Paste                                           '貼上 圖片

             .Chart.Export Filename:=ThePicture                     '匯出 圖片

             .Delete                                                '刪除 圖表

        End With

    End With

    Image1.Picture = LoadPicture(ThePicture)                         'Image1 指定圖片

End Sub
hong912

TOP

回復 18# hong912

請上傳無法讀取的問題檔案
應該只要是能插入到工作表中的圖片均可讀取才對
學海無涯_不恥下問

TOP

回復 19# Hsieh
Hsieh版大, 早晨
昨夜自行研究了很久, 用相機及手機攝影了照片及上網下載圖片試試, 並沒有問題, 再了解圖片格式, 也有不同格式, 同樣地能傳回圖片, 後來小弟把不能傳回的圖片剪下放進圖像中心, 再從圖像中心貼回檔案內, 問題竟解決,
謝過大大回應, 感恩..
hong912

TOP

        靜思自在 : 人的眼睛長在前面,只看到別人的缺點,絲毫看不到自己的缺點。
返回列表 上一主題