Hsieh

回復 20# jackyliu

手動刪除程式碼另存新檔就好啦
要自動另存時刪除程式碼，可利用BEFORE_SAVE事件完成(如附件)
insert_pictures.rar (1.74 MB)

下載次數: 28

2011-2-23 08:23

jackyliu

版大  我權限還太小, 所以您的rar 附件檔 , 無法下載....
可否明示~ ~

Hsieh

回復 22# jackyliu

thisworkbook模組

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.   Select Case vbc.Type
   
7.   Case vbext_rk_Project, vbext_wt_Browser, vbext_ct_MSForm '註
   
8.     .VBComponents.Remove .Item(vbc.Name)
   
9. 
   
10.   Case Else
    
11.     .VBComponents(vbc.Name).CodeModule.DeleteLines 1, _
    
12.     .VBComponents(vbc.Name).CodeModule.CountOfLines
    
13. 
    
14.   End Select
    
15. Next
    
16. End With
    
17. End If
    
18. End Sub
    
19. 
    
20. 
    
21. Private Sub Workbook_Open()
    
22. Set d = CreateObject("Scripting.Dictionary")
    
23. fd = ThisWorkbook.Path & "\" '圖檔目錄
    
24. fs = Dir(fd & "*.jpg")
    
25. Do Until fs = ""
    
26. If InStr(fs, "-") = 0 Then '只有數值
    
27.    d(fs) = "H" & Val(fs) + 2 '因為在第列所以加2
    
28.    ElseIf Len(fs) - Len(Replace(fs, "-", "")) = 1 Then '只有1個分隔符號
    
29.    '第2碼為C就是I欄，否則就在J欄
    
30.    V = Split(fs, "-")(1)
    
31.      If Split(fs, "-")(1) Like "C*" Then d(fs) = "I" & Val(fs) + 2 Else d(fs) = "J" & Val(fs) + 2
    
32.    Else
    
33.    '第3碼是1就在K欄，2就在L欄，其餘在M欄
    
34.    ar = Split(fs, "-")
    
35.    p = IIf(ar(1) = "C", Asc("K"), Asc("L")) '第2碼是C就傳回"K"的字元碼，第2碼是T就傳回"L"的字元碼給變數p
    
36.    k = Chr(Val(ar(2)) * 2 + p) '字串變數k的值是第3碼+p對應到的字串(就是欄位)
    
37.    d(fs) = k & Val(fs) + 2
    
38. End If
    
39. fs = Dir
    
40. Loop
    
41. With Sheets("Sheet1")
    
42. .Pictures.Delete '清除所有圖片
    
43. Application.ScreenUpdating = False
    
44. For Each ky In d.keys
    
45.    Set A = .Range(d(ky)) '圖片插入的位置
    
46.       With .Pictures.Insert(fd & ky) '插入圖檔
    
47.          .ShapeRange.LockAspectRatio = msoFalse '解除長寬比例
    
48.          .Top = A.Top
    
49.          .Left = A.Left
    
50.          .Height = A.Height
    
51.          .Width = A.Width
    
52.        End With
    
53. Next
    
54. End With
    
55. Application.ScreenUpdating = True
    
56. End Sub

複製代碼

jackyliu

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

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

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

Hsieh

回復 24# jackyliu

在ThisworkBook模組內，直接貼入程式碼
開啟檔案時就會自動載入圖片
另存新檔就會自動刪除程式碼另存

jackyliu

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

Hsieh

回復 26# jackyliu


    工具/巨集/安全性
勾選信任存取Visual Basic專案

下載 (31.38 KB)

2011-2-23 22:14

jackyliu

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

jackyliu

板大   這幾天我另外做一個撈取資料庫資料 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

Hsieh

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

複製代碼