|

樓主 |
發表於 2013-8-24 10:19:02
|
顯示全部樓層
2013/8/24 程式碼
- Private Sub cmdDelPic_Click()
- '將之前產生的圖片清除
- Sheet3.Activate
- Sheet3.Shapes.SelectAll
- Selection.Delete
- Sheet1.Activate
-
- MsgBox "刪除完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"
- End Sub
- Private Sub cmdMerge_Click()
- Dim a, b, c As Integer '宣告a,b,c為整數
-
- Dim objsheet As Worksheet
-
- WorkName = Excel.ActiveWorkbook.Name '此檔案名稱
-
-
- i = 6
- Z = 1
-
- picHeight = Range("b1")
- picWidth = Range("b2")
- picColumn = Range("b3")
- picAngle = Range("b4")
-
- '將之前產生的圖片清除
- Sheet3.Activate
- Sheet3.Shapes.SelectAll
- Selection.Delete
-
-
- While Sheet1.Range("b" & i) <> ""
-
- FilePath = Sheet1.Range("a" & i)
- Filename = Sheet1.Range("b" & i)
-
- If FilePath = "" Then
- Fullpath = Excel.Workbooks(WorkName).Path & "" & Filename
- Else
- If Right(FilePath, 1) = "" Then
- Fullpath = FilePath & Filename
- Else
- Fullpath = FilePath & "" & Filename
- End If
- End If
-
- '檢查檔案是否存在
- If Dir(Fullpath) <> "" Then
-
- Sheet3.Activate
-
- Sheet3.Range(picColumn & Z).Select
-
- ActiveSheet.Pictures.Insert(Fullpath).Select
-
-
- If picHeight > 0 Then
- Selection.ShapeRange.Height = 28.5 * picHeight
- '調整列高度
- Sheet3.Rows(Z).RowHeight = 28.5 * picHeight
-
- End If
-
- If picWidth > 0 Then
- Selection.ShapeRange.Width = 28.5 * picWidth
- End If
-
- Selection.ShapeRange.Rotation = picAngle
-
- Selection.Cut '2007才需要底下這樣作
-
- Sheet3.Range(picColumn & Z).Select
-
- ActiveSheet.Paste
- Else
- MsgBox "檔案:" & Fullpath & "不存在,請查看是否有拼錯字"
- End If
- i = i + 1 '讀取下一個名稱
- Z = Z + 1
- Wend
-
-
- MsgBox "執行完成", vbOKOnly, "彰化一整天的blog(http://272586.blogspot.com)"
- End Sub
複製代碼 |
|