■「図形に合わせて塗りつぶしを回転する」設定(補足

昨日の補足、というかついでに、「図形に合わせて塗りつぶしを回転する」ON|OFF切り替えてみるコード。

Option Explicit

Sub try_2()
　　Dim sp As Shape

　　Set sp = ActiveSheet.Shapes(1)
　　If sp.Fill.Type = msoFillGradient Then
　　　　Call fillRotate(sp) ', True)
　　End If
　　Set sp = Nothing
End Sub
'---------------------------------------------------------------------
Sub fillRotate(ByRef sp As Shape, _
　　　　　　　 Optional ByVal flg As Boolean = False)
　　Dim ws As Worksheet
　　Dim wrk As String
　　Dim tmp As String
　　Dim n　 As Long
　　Dim L　 As Single
　　Dim T　 As Single

　　wrk = Application.DefaultFilePath & "¥rotatetemp.htm"
　　Application.ScreenUpdating = False
　　L = sp.Left
　　T = sp.Top
　　Set ws = sp.Parent
　　With Workbooks.Add(xlWBATWorksheet)
　　　　sp.Cut
　　　　.Sheets(1).Paste
　　　　Application.DisplayAlerts = False
　　　　.SaveAs Filename:=wrk, FileFormat:=xlHtml
　　　　Application.DisplayAlerts = True
　　　　.Close False
　　End With

　　n = FreeFile
　　Open wrk For Input As #n
　　tmp = StrConv(InputB(LOF(n), #n), vbUnicode)
　　Close #n
　　tmp = Replace$(tmp, "rotate=""t""", "")
　　If flg Then
　　　　tmp = Replace$(tmp, "method=", "rotate=""t"" method=")
　　End If
　　n = FreeFile
　　Open wrk For Output As #n
　　Print #n, tmp
　　Close #n

　　With Workbooks.Open(wrk, ReadOnly:=True)
　　　　.Sheets(1).Shapes(1).Cut
　　　　.Close False
　　End With
　　With ws
　　　　.Paste
　　　　With .Shapes(.Shapes.Count)
　　　　　　.Left = L
　　　　　　.Top = T
　　　　End With
　　End With
　　ActiveCell.Activate
　　With CreateObject("Scripting.FileSystemObject")
　　　　.GetFile(wrk).Delete
　　　　.GetFolder(Replace$(wrk, ".htm", ".files")).Delete
　　End With

　　Set sp = Nothing
　　Set ws = Nothing
　　Application.ScreenUpdating = True
End Sub

昨日と今日のコードは2003でしか検証してません。
2007ではhtmファイルを弄くる手法は全く使えません。

#ちなみに2007ではコードで[グラデーション]を設定すると、ON既定で自動的にチェックが付くようです。



#2010.08.21追記）
#最近気付いたけど2007から FillFormat.RotateWithObject Property が追加になってたんですね。
#コード制御可能です :)