一個查詢的表單, - Excel程式區 - 麻辣家族討論版版

麻辣家族討論版版 » Excel程式區 » 一個查詢的表單,

返回列表下一主題上一主題發帖

一個查詢的表單,

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

1^# 跳轉到 »

發表於 2012-9-15 17:16 | 顯示全部帖子

回復 1# hong912
UserForm的程式碼

Option Explicit '在模組層次中強迫每個在模組裏的變數都必須明確的宣告。
Private Const 編號 = 3 '資料庫的欄位列號
Private Const ThePicture = "d:\ttt.gif" '設立匯出圖片的路徑檔名
Dim Ar(10), Sh As Worksheet
'Dim Ar()
Private Sub UserForm_Initialize() '表單初始化的預設事件程序
Dim I As Integer
Set Sh = Sheets("Sheet1") '資料庫的工作表
With Sh
ComboBox1.List = .Range("a4", .[a4].End(xlDown)).Value '指定 ComboBox1的內容
End With
'Dim Ar()時可用下式
'Ar = Array(TextBox1, TextBox2, TextBox3, TextBox4, TextBox5, TextBox6, TextBox7, TextBox8, TextBox9, TextBox10, TextBox11)
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 ComboBox1_Change()
Dim Sp As Picture, I As Integer
If ComboBox1.ListIndex > -1 Then '選擇 ComboBox1的內容
For I = 0 To UBound(Ar)
Ar(I).Text = Sh.Cells(編號 + ComboBox1, I + 2)
Next
End If
With Sh
For Each Sp In .Pictures '尋找N欄中的圖片,複製之
If Sp.TopLeftCell.Address(0, 0) = "N" & 編號 + ComboBox1 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
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '表單絕束時預設事件程序
If Dir(ThePicture) <> "" Then Kill ThePicture '刪除匯出的圖片
End Sub

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

2^#

發表於 2012-9-16 16:07 | 顯示全部帖子

回復 4# hong912
試試看

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
If ComboBox1.ListIndex > -1 Then '選擇 ComboBox1的內容
For I = 0 To UBound(Ar)
If I <> UBound(Ar) Then
Ar(I).Text = Sh.Cells(編號 + ComboBox1, I + 2)
Else
'2, 在第11個TextBox11物件中, 可否做到把sheet1第11欄及12欄合拼顯示,如123aaa
Ar(I).Text = Sh.Cells(編號 + ComboBox1, I + 2) & Sh.Cells(編號 + ComboBox1, I + 3)
End If
Next
End If
With Sh
For Each Sp In .Pictures '尋找N欄中的圖片,複製之
If Sp.TopLeftCell.Address(0, 0) = "N" & 編號 + ComboBox1 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

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2012-9-21 17:03 | 顯示全部帖子

回復 7# hong912
ComboBox1 增加一欄內容

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 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

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

4^#

發表於 2012-9-22 14:30 | 顯示全部帖子

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

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

5^#

發表於 2012-9-28 16:40 | 顯示全部帖子

回復 25# 周大偉

Dim PicAr() As Picture '圖片陣列
Dim fs As String ' *** = "E:\temp.jpg" '暫存圖片目錄位置
Private Const r = 4 '資料起始列號
Private Sub UserForm_Initialize() '表單初始化
Dim Pic As Picture
fs = CurDir & "\temp.jpg" '*** 這裡修改為當下的目錄 ( CurDir )為暫存圖片目錄位置 ***
With Sheet1
ReDim PicAr(.Pictures.Count)
For Each Pic In .Pictures '將每個圖片置入陣列
Set PicAr(Pic.TopLeftCell.Row - r) = Pic
Next
ComboBox1.List = .Range("A4", .[A4].End(xlDown).Offset(, 12)).Value '下拉清單內容
End With
Image1.PictureSizeMode = fmPictureSizeModeStretch '圖片載入的型態
End Sub

複製代碼

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2012-9-29 16:34 | 顯示全部帖子

回復 29# 周大偉
CurDir: 傳回前目錄位置
當使用開啟舊檔指令: 所看到的目錄位置

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

7^#

發表於 2012-9-30 15:50 | 顯示全部帖子

本帖最後由 GBKEE 於 2012-9-30 15:51 編輯

回復 33# hong912
修改查詢檔案表單程式碼如下

Dim PicAr() As Picture '圖片陣列
Dim fs As String, Sh As Worksheet ' 表單查詢表 = "E:\temp.jpg" '暫存圖片目錄位置
Private Const r = 4 '資料起始列號
Private Sub UserForm_Initialize() '表單初始化
Dim Pic As Picture
查看資料庫
fs = CurDir & "\temp.jpg" '表單查詢表這裡修改為當下的目錄 ( CurDir )為暫存圖片目錄位置表單查詢表
With Sh
ReDim PicAr(.Pictures.Count)
For Each Pic In .Pictures '將每個圖片置入陣列
Set PicAr(Pic.TopLeftCell.Row - r) = Pic
Next
ComboBox1.List = .Range("A4", .[A4].End(xlDown).Offset(, 12)).Value '下拉清單內容
End With
Image1.PictureSizeMode = fmPictureSizeModeStretch '圖片載入的型態
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) '關閉表單
If Dir(fs) <> "" Then Kill fs '刪除暫存圖片檔案
Sh.Parent.Close 0 '關閉資料庫檔案
End Sub
Private Sub 查看資料庫()
Dim 資料庫 As String, Wo As Workbook, Msg As Boolean 'Boolean型態的預設值為 False
資料庫 = "D:\資料庫.XLS" '資料庫檔案的路徑目錄
For Each Wo In Workbooks '活頁簿物件集合
If Wo.FullName = 資料庫 Then '資料庫檔案開啟中
Msg = True
Set Sh = Wo.Sheets(1) '將變數指定為第一個工作表
Exit For
End If
Next
Application.ScreenUpdating = False
'ScreenUpdating 屬性如果螢幕更新功能是開啟的則為 True。讀/寫 Boolean。
If Msg = False Then Set Sh = CreateObject(資料庫).Sheets(1)
'資料庫檔案如未開啟, 開啟它:將變數指定為第一個工作表
Application.ScreenUpdating = True
End Sub

複製代碼

靜思自在 : 愛不是要求對方，而是要由自身的付出。

返回列表下一主題上一主題