図を差し替えたいだけなんじゃ~!!!

f:id:elve:20210801071418p:plain
はい、こんな封筒データが有ったとします。個人情報は疑似個人情報データ生成サービスで生成した偽情報です。
季節が変わったので図を差し替えて欲しいと言わたとしますよー。毎月画像差し替えです。
そんじゃドキュメントと同じフォルダにある、一番新しいpngファイルに差し替えるマクロを組みましょう、と。

  • 図のサイズは一緒
  • 図はヘッダーにある
  • 図の名前は”図 12”

f:id:elve:20210801055707p:plain

手動でやるなら図を選択して調整から「図の変更」するだけじゃん? なんか簡単そうじゃん?

・図の変更のコードはマクロの記録で得られませんし、 2010版VBAヘルプを探してもみつけられません。

https://answers.microsoft.com/ja-jp/msoffice/forum/all/excel-2007-vba/48b2e8a6-ad64-41bc-8ebf-a299e7bf04f8

えええええええええええええ(´;ω;`)

んで、ザクザクーっと書くと

Function get_newestFile(t As String) As String
 '指定拡張子の最新ファイル名取得
If Len(t) > 4 Then
get_newestFile = ""
Exit Function
End If
Dim p As String: p = Me.Path & "\"
Dim newest As Date
Dim filename As String
Dim taegetname As String
filename = Dir(p & "*." & t)
Do Until filename = ""
If FileDateTime(p & filename) > newest Then
newest = FileDateTime(p & filename)
taegetname = filename
End If
filename = Dir()
Loop
get_newestFile = taegetname
End Function
Sub 図差替()
Dim p As String: p = Me.Path & "\"
Dim se As Section
For Each se In Me.Sections
Dim he As HeaderFooter: Set he = se.Headers(wdHeaderFooterPrimary)
Dim sh As Shape: Set sh = he.Shapes("図 12")
Dim filename As String: filename = get_newestFile("png")
Dim newsh As Shape
Set newsh = he.Shapes.AddPicture(p & filename, False, True, sh.Left, sh.Top, sh.Width, sh.Height)
sh.Delete
newsh.Name = "図 12"
Next
End Sub

で、実行するじゃない
f:id:elve:20210801063039p:plain
どこいった・・・*1
図の位置が相対的なのになってるとうまく行かないのかな?←よくわかってない。
修正したらこんな感じ

Function get_newestFile(t As String) As String
 '指定拡張子の最新ファイル名取得
If Len(t) > 4 Then
get_newestFile = ""
Exit Function
End If
Dim p As String: p = Me.Path & "\"
Dim newest As Date
Dim filename As String
Dim taegetname As String
filename = Dir(p & "*." & t)
Do Until filename = ""
If FileDateTime(p & filename) > newest Then
newest = FileDateTime(p & filename)
taegetname = filename
End If
filename = Dir()
Loop
get_newestFile = taegetname
End Function
Sub 図差替()
Dim p As String: p = Me.Path & "\"
Dim se As Section
For Each se In Me.Sections
Dim he As HeaderFooter: Set he = se.Headers(wdHeaderFooterPrimary)
Dim sh As Shape: Set sh = he.Shapes("図 12")
Dim filename As String: filename = get_newestFile("png")
Dim newsh As Shape
Set newsh = he.Shapes.AddPicture(p & filename, False, True, , , sh.Width, sh.Height)
With newsh
.WrapFormat.Type = sh.WrapFormat.Type
.RelativeHorizontalPosition = sh.RelativeHorizontalPosition
.LeftRelative = sh.LeftRelative
.RelativeVerticalPosition = sh.RelativeVerticalPosition
.TopRelative = sh.TopRelative
.Top = sh.Top
.Left = sh.Left
.LockAnchor = sh.LockAnchor
End With
sh.Delete
newsh.Name = "図 12"
Next
End Sub

okok!!
f:id:elve:20210801070336p:plain

*1:最初普通に成功してしまったw

どのくらい面白かった?

星を押して送信してね

平均 0 / 5. Vote count: 0

是非フォローしてください

最新の情報をお伝えします

コメントする

メールアドレスが公開されることはありません。 が付いている欄は必須項目です