VBA로 이미지 삽입 매크로
3597 단어 VBA
그래서 메모 쓰기입니다.
이미지
VBA 코드
'貼り付け基準位置
Public Const PST_INDEX As Long = 2
'貼り付け増加インデックス
Public Const ADD_INDEX As Long = 8
'余白設定
Public Const MARGIN As Long = 10
'写真の配置元
Public Const SRC_PATH As String = "C:\Users\user01\Desktop\test\写真張り付け用\"
'写真の配置シート
Public Const SRC_SHEET As String = "画像貼り付けテスト"
'関数呼び出しテスト
Public Sub test()
Dim buf As String, cnt As Long
Dim imgpath As String
Application.ScreenUpdating = False
cnt = 0
'写真の配置元のjpg画像を読み出す
buf = Dir(SRC_PATH & "*.jpg")
Do While buf <> ""
imgpath = SRC_PATH & buf
Call PasteImg(imgpath, ThisWorkbook.Sheets(SRC_SHEET).Range("C" & PST_INDEX + cnt * ADD_INDEX))
cnt = cnt + 1
buf = Dir()
Loop
Application.ScreenUpdating = True
End Sub
'---------------------------------------------------
'画像中央揃え貼り付け関数
'---------------------------------------------------
'(引数)filepath:貼り付け対象画像ファイルパス
' srcRange:貼り付け先rangeオブジェクト
'---------------------------------------------------
Private Sub PasteImg(filepath As String, ByVal srcRange As Range)
Dim pic As Variant, dstw As Integer, dsth As Integer
Dim hper As Single, wper As Single, avgh As Single, avgw As Single
Dim dblScal As Double
dstw = srcRange.MergeArea.Width
dsth = srcRange.MergeArea.Height
'ここでファイルパスの存在確認関数を使う。
If IsFileExists(filepath) = False Then
Application.ScreenUpdating = True
Exit Sub
End If
'画像の貼り付け
Set pic = ActiveSheet.Shapes.AddPicture( _
Filename:=filepath, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=0, _
Top:=0, _
Width:=0, _
Height:=0)
With pic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
'高さの縮尺(貼り付け先高さ/画像高さ)
hper = srcRange.MergeArea.Height / .Height
'幅の縮尺(貼り付け先幅/画像幅)
wper = srcRange.MergeArea.Width / .Width
'高さの縮尺 > 幅の縮尺
If hper > wper Then
.Height = .Height * wper - MARGIN
.Width = srcRange.MergeArea.Width - MARGIN
Else
.Height = srcRange.MergeArea.Height - MARGIN
.Width = .Width * hper - MARGIN
End If
'画像サイズが貼り付け先の高さを超えている
If srcRange.MergeArea.Height <= .Height + MARGIN Then
.LockAspectRatio = msoTrue
dblScal = .Height / (srcRange.MergeArea.Height - MARGIN)
.ScaleHeight dblScal, msoFalse, msoScaleFromTopLeft
End If
'中央へ調整
avgh = (srcRange.MergeArea.Height / 2) - (.Height / 2)
avgw = (srcRange.MergeArea.Width / 2) - (.Width / 2)
.Top = srcRange.MergeArea.Top + avgh
.Left = srcRange.MergeArea.Left + avgw
Set pic = Nothing
End With
End Sub
'---------------------------------------------------
'ファイル存在チェック
'---------------------------------------------------
'(引数)srcpath:チェックファイルパス
'---------------------------------------------------
Function IsFileExists(srcpath As String) As Boolean
Dim rtn As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
rtn = FSO.FileExists(srcpath)
Set FSO = Nothing
IsFileExists = rtn
End Function
Reference
이 문제에 관하여(VBA로 이미지 삽입 매크로), 우리는 이곳에서 더 많은 자료를 발견하고 링크를 클릭하여 보았다 https://qiita.com/ReGadex/items/196e59fff5877ee3539e텍스트를 자유롭게 공유하거나 복사할 수 있습니다.하지만 이 문서의 URL은 참조 URL로 남겨 두십시오.
우수한 개발자 콘텐츠 발견에 전념 (Collection and Share based on the CC Protocol.)