- 帖子
- 69
- 主題
- 12
- 精華
- 0
- 積分
- 86
- 點名
- 0
- 作業系統
- windows xp
- 軟體版本
- office 2000
- 閱讀權限
- 20
- 性別
- 女
- 註冊時間
- 2011-2-14
- 最後登錄
- 2023-3-19
|
32#
發表於 2011-6-27 06:37
| 只看該作者
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)
|
