　暱稱: 鹹蛋

帖子: 62
主題: 13
精華: 0
積分: 109
點名: 0
作業系統: Win 10家用版
軟體版本: Office 2013
閱讀權限: 20
性別: 女
來自: 新北
註冊時間: 2016-1-27
最後登錄: 2024-8-12

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2020-2-13 17:20 | 只看該作者

[發問] 儲存格範圍複製&另存成TIF檔

請教各位大大：
想在excel表格AJ4欄位雙擊滑鼠後，
將M2:V27這個範圍複製成tif檔(儲存於桌面)，
再開啟outlook程式新郵件後
1.將桌面的tif檔加入附件中
2.再另外複製M2:V27範圍成圖片，貼在郵件內文中
目前有問頭如下：
1.M2:V27這個範圍複製成tif檔，儲存到桌面後，檔案是空值無資料。
因老闆要求，檔案必須為tif檔
2.複製M2:V27範圍成圖片，貼在郵件內文中：
有在剪貼簿，但是新郵件時，不會出現在內文，要自己手動再按貼上才有....
請問以上程式碼該如何修正？
感謝各位大大~~~~

Sub Mail_Range()
Dim Source As Range
Dim temp As Object, newmail As Object, strg As String
Set Source = Nothing
On Error Resume Next
'新增程式碼開始，作用中儲存格停在哪個部門別，就設定為Source
If ActiveCell.Address = Cells(4, 14).Address Then
Set Source = Range("M2:V27").SpecialCells(xlCellTypeVisible)
ElseIf ActiveCell.Address = Cells(4, 36).Address Then
Set Source = Range("AI2:AR27").SpecialCells(xlCellTypeVisible)
Source.Copy
Source.CopyPicture
With ActiveSheet.ChartObjects.Add(1, 1, Source.Width, Source.Height) '新增圖表
.Chart.Paste '貼上圖片
.Chart.Export Filename:="C:\Users\paz\Desktop\" & "Paz " & "Salary " & Range("B3") & "-" & Range("D3") & ".tif" '匯出圖片
.Delete '刪除圖表
End With
Set temp = CreateObject("outlook.application")
Set newmail = temp.CreateItem(0) '使用outlook?建新?件
With newmail
.To = "[email protected]" '收件人
.CC = "" '抄送人
.Subject = "Salary " & Range("B3") & "-" & Range("D3") '?件??
.Body = Selection.PasteSpecial
.Attachments.Add "C:\Users\paz\Desktop\" & "Paz " & "Salary " & Range("B3") & "-" & Range("D3") & ".tif" '添加附件
.Display
'.Send
End With
Else
End If
End Sub

複製代碼

樓主熱帖

takeshilin88

　暱稱: 鹹蛋

中學生 Rank: 2

帖子: 62
主題: 13
精華: 0
積分: 109
點名: 0
作業系統: Win 10家用版
軟體版本: Office 2013
閱讀權限: 20
性別: 女
來自: 新北
註冊時間: 2016-1-27
最後登錄: 2024-8-12

2^#

發表於 2020-10-14 15:32 | 只看該作者

請教各位大大：
想在excel表格AJ4欄位雙擊滑鼠後，
將M2:V27這個範圍複製成tif檔(儲存於桌面)，
再開啟o ...
takeshilin88 發表於 2020-2-13 17:20

請問有高手可以指導一下嗎？

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

帖子: 109
主題: 2
精華: 0
積分: 114
點名: 0
作業系統: Win7 Win10
軟體版本: Office 2019 WPS
閱讀權限: 20
性別: 男
來自: 深圳
註冊時間: 2013-2-2
最後登錄: 2024-11-6

3^#

發表於 2020-10-28 08:42 | 只看該作者

本帖最後由 Joforn 於 2020-10-28 08:43 編輯

呃，2020-2-13发的新帖，都10月了还在顶帖，好執著啊:D

世界那麼大，可我想去哪？

TOP

Joforn

　暱稱: 南宮飄雪

中學生 Rank: 2

帖子: 109
主題: 2
精華: 0
積分: 114
點名: 0
作業系統: Win7 Win10
軟體版本: Office 2019 WPS
閱讀權限: 20
性別: 男
來自: 深圳
註冊時間: 2013-2-2
最後登錄: 2024-11-6

4^#

發表於 2020-10-28 10:30 | 只看該作者

剛好今天不太忙，寫了一個效率高點了模組，可依照文件的相應后綴名生成指定格式的圖片文檔：

Sub Test()
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.BMP")
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.jpg")
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.EMF")
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.PNG")
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.GIF")
Debug.Print SaveRangeToPictrue(Range("M2:V27"), ThisWorkbook.Path & Application.PathSeparator & "Test.TIF")
End Sub

複製代碼

SaveRangeToPictrue函數代碼過長，直接放附件里了。

SaveRangeToPictrue.zip (61.05 KB)

世界那麼大，可我想去哪？

TOP

takeshilin88

　暱稱: 鹹蛋

中學生 Rank: 2

帖子: 62
主題: 13
精華: 0
積分: 109
點名: 0
作業系統: Win 10家用版
軟體版本: Office 2013
閱讀權限: 20
性別: 女
來自: 新北
註冊時間: 2016-1-27
最後登錄: 2024-8-12

5^#

發表於 2020-10-28 11:22 | 只看該作者

回復 4# Joforn

感謝大大的幫忙，
終於有人理我了，謝謝~~

TOP