| |
▼岳 さん：
すみません、１箇所ミスがあったので訂正します。
Sub トリミングTEST()
Dim slcRng As Range, intMsg As String
Dim strPic As Variant, myPic As Object
strPic = Application.GetOpenFilename(, , "画像ファイルを選択")
If VarType(strPic) = vbBoolean Then Exit Sub
With Workbooks.Add
Application.ScreenUpdating = False
With .ActiveSheet
.Cells.ColumnWidth = 0.38
.Cells.RowHeight = 3.75
.SetBackgroundPicture strPic
Set myPic = .Pictures.Insert(strPic)
myPic.Visible = False
End With
ActiveWindow.DisplayGridlines = False
Application.ScreenUpdating = True
Set slcRng = Application.InputBox("切り取り範囲を選択", Type:=8)
intMsg = InputBox("保存ファイル名は？")
If intMsg = "" Or slcRng Is Nothing Then GoTo ErrHdl
intMsg = "\" & intMsg
myPic.Visible = True
Application.ScreenUpdating = False
slcRng.CopyPicture xlScreen, xlPicture
With ActiveSheet.ChartObjects.Add(0, 0, slcRng.Width, slcRng.Height).Chart
.Paste
.Export Filename:=ThisWorkbook.Path & intMsg & ".gif", filtername:="GIF"
.Parent.Delete
End With
MsgBox "ブックが保存されているフォルダに保存されました"
ErrHdl:
.Close False
Application.ScreenUpdating = True
End With
End Sub
|
|
Lindy
- 07/11/26(月) 15:25 -
