' [291.xls]



' [Module1] のコード
'★★☆　文字画像を作成する　☆★★

Option Explicit

Sub start()

    UserForm1.Show

End Sub


' [UserForm1] のコード
Option Explicit

Private Sub CommandButton1_Click()
Dim cw
Dim 文字画像 As Object
Dim bbb As Object
    
    With [E8]
        [E16].Copy
        .PasteSpecial Paste:=xlFormats

        cw = .ColumnWidth
        
        '図形をワークシートに作成
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 10, 10).Select
        
        '作成した図形への参照を変数に代入
        Set 文字画像 = Selection
        
        '書き込まれた文字列を一旦セルに書き込む
        .FormulaR1C1 = TextBox1.Text
        
        'セルの幅に合わせた画像が生成されるので、セル幅を文字列の幅に合わせる
        .EntireColumn.AutoFit
        
        'セルに書き込まれた文字をコピー
        .Copy
        
        'オブジェクトを選択して文字を貼り付け
        文字画像.Select
        ActiveSheet.Paste
        
        'この時点で新たな図形が生成される
        '新たに生成された図形を変数に代入
        Set bbb = Selection
        
        '元の図形を削除
        文字画像.Delete
        .ClearContents
        
        '変更したセル幅を戻す
        .ColumnWidth = cw
        
    End With
    
        '文字図形を選択して指定したサイズに変更
        bbb.Select
        
    With Selection.ShapeRange
    
        .Fill.ForeColor.RGB = RGB(255, 200, 200)
        .Left = [E8].Left
        .Top = [E8].Top
        .ScaleWidth Val(TextBox2.Value), msoFalse, msoScaleFromTopLeft
        .ScaleHeight Val(TextBox2.Value), msoFalse, msoScaleFromTopLeft
    
    End With
    
    [G8].Copy
    [E8].PasteSpecial Paste:=xlFormats
    Application.CutCopyMode = False
    [A1].Activate
    bbb.Select
    Set 文字画像 = Nothing
    Set bbb = Nothing
    Unload Me
    
End Sub

Private Sub TextBox2_Change()
    
    '画像の倍率指定の条件を設定して、条件内で無ければ文字を消す
    If IsNumeric(TextBox2.Value) = False Or _
        Val(TextBox2.Value) > 10 Then
        
        TextBox2.Value = ""
        Exit Sub
        
    End If
    
End Sub