返回列表 上一主題 發帖

[發問] 如何篩選圖片,並插入指定的欄位

[發問] 如何篩選圖片,並插入指定的欄位

本帖最後由 jackyliu 於 2011-2-15 01:40 編輯

請教 高手們:
如何將C:\TEST\地下的圖片 經過篩選 插入所定義的欄位內,
可否幫忙一下,因權限關係,可否貼程式碼.... 如附件 ! 萬分感激 !

已知條件
1. 圖片插入範圍H、I、J、K、L、M
2. 圖片儲存位置於C:\TEST\*.JPG(副檔名)
3. 圖片命名規則1-T、1-T-O
4. 圖片插入規則1為插入第一列、T為插入第一列的(T)第三碼為0、1、2、3, 若有第三碼則依序插入至K、L、M 欄位
5. 圖片大小 高度2.7cm、寬度3.6cm
6. 資料比數不設限10筆,所以 匯差入的圖片可能會到達第200列的某欄位

test01.rar (51.4 KB)

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True And Cancel = False Then
Dim vbc As Object
With ThisWorkbook.VBProject
For Each vbc In .VBComponents
  Select Case vbc.Type
  Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
    .VBComponents.Remove .Item(vbc.Name)

  Case Else
    .VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    .VBComponents(vbc.Name).CodeModule.CountOfLines

  End Select
Next
End With
End If
End Sub


Private Sub Workbook_Open()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '圖檔目錄
fs = Dir(fd & "*.jpg")
Do Until fs = ""
If InStr(fs, "-") = 0 Then '只有數值
   d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
   ElseIf Len(fs) - Len(Replace(fs, "-", "")) = 1 Then '只有1個分隔符號
   '第2碼為C就是I欄,否則就在J欄
   V = Split(fs, "-")(1)
     If Split(fs, "-")(1) Like "C*" Then d(fs) = "I" & Val(fs) + 2 Else d(fs) = "J" & Val(fs) + 2
   Else
   '第3碼是1就在K欄,2就在L欄,其餘在M欄
   ar = Split(fs, "-")
   p = IIf(ar(1) = "C", Asc("K"), Asc("L")) '第2碼是C就傳回"K"的字元碼,第2碼是T就傳回"L"的字元碼給變數p
   k = Chr(Val(ar(2)) * 2 + p) '字串變數k的值是第3碼+p對應到的字串(就是欄位)
   d(fs) = k & Val(fs) + 2
End If
fs = Dir
Loop
With Sheets("Sheet1")
.Pictures.Delete '清除所有圖片
Application.ScreenUpdating = False
For Each ky In d.keys
   Set A = .Range(d(ky)) '圖片插入的位置
      With .Pictures.Insert(fd & ky) '插入圖檔
         .ShapeRange.LockAspectRatio = msoFalse '解除長寬比例
         .Top = A.Top
         .Left = A.Left
         .Height = A.Height
         .Width = A.Width
       End With
Next
End With
Application.ScreenUpdating = True
End Sub

目前想改成從I 欄位開始插入圖片;圖片名稱有1,1-1,1-2 ~1-20 ,共21張圖,
測試了好久一直改不出來,幫忙指點好嗎?

2-1.jpg (15.01 KB)

2-1.jpg

TOP

可以了 耶  , 感謝您的幫忙

TOP

回復 29# jackyliu

試試看
  1. Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  2. If SaveAsUI = True And Cancel = False Then
  3. Dim vbc As Object
  4. With ThisWorkbook.VBProject
  5. For Each vbc In .VBComponents
  6.   If vbc.Type = 1 Then
  7.   .VBComponents.Remove .VBComponents(vbc.Name)
  8.   Else
  9.     .VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
  10.     .VBComponents(vbc.Name).CodeModule.CountOfLines
  11.   End If
  12. Next
  13. End With
  14. End If
  15. End Sub
複製代碼
學海無涯_不恥下問

TOP

板大   這幾天我另外做一個撈取資料庫資料 VBA ,資料撈取完,自動另存新檔 並且刪除程式碼;
直接 複製 板大上頭的 Code 做自動另存新檔 並且刪除程式碼,可是 產出的新檔裡都會程式Code.
可否指教一下,哪裡出問題了....

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True And Cancel = False Then
Dim vbc As Object
With ThisWorkbook.VBProject
For Each vbc In .VBComponents
  Select Case vbc.Type
  Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
    .VBComponents.Remove .Item(vbc.Name)
  Case Else
    .VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    .VBComponents(vbc.Name).CodeModule.CountOfLines
  End Select
Next
End With
End If
End Sub

TOP

哇....  太勵害了
這陣子 辛苦您了 ~

TOP

回復 26# jackyliu


    工具/巨集/安全性
勾選信任存取Visual Basic專案
學海無涯_不恥下問

TOP

本帖最後由 jackyliu 於 2011-2-23 21:24 編輯

另存新檔  會有錯誤訊息耶 ....
而且  新建立的檔案內 ThisWorkbook 的程式code 並沒有清除,
應該 是說 " 程式code 和圖片 "  一起 另存新檔耶

1004.jpg (11.45 KB)

1004.jpg

TOP

回復 24# jackyliu

在ThisworkBook模組內,直接貼入程式碼
開啟檔案時就會自動載入圖片
另存新檔就會自動刪除程式碼另存
學海無涯_不恥下問

TOP

將上面 程式code 複製到 Modul1, 接著要去執行巨集...
去沒有 巨集名稱耶 ...  

正常之前 巨集名稱是 :Ex() , Sub auto_open()

現在變成 不會 Run 了耶....

TOP

        靜思自在 : 【蒙蔽的自由】人常在什麼都可以自由自在的時候,卻被這種隨心所欲的自由蒙蔽,虛擲時光而毫無覺知。
返回列表 上一主題