昨日の補足、というかついでに、「図形に合わせて塗りつぶしを回転する」ON|OFF切り替えてみるコード。
昨日と今日のコードは2003でしか検証してません。
2007ではhtmファイルを弄くる手法は全く使えません。
#ちなみに2007ではコードで[グラデーション]を設定すると、ON既定で自動的にチェックが付くようです。
#2010.08.21追記)
#最近気付いたけど2007から FillFormat.RotateWithObject Property が追加になってたんですね。
#コード制御可能です :)
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 が追加になってたんですね。
#コード制御可能です :)