印鑑画像を作成してExcelに挿入するVBAマクロ

リモートワークが増えてきたことで、押印処理についても電子で決済をすることが増えてきたかと思います。

まあ自分が所属している案件は考え方が古すぎるので、印刷物に印鑑を押すためだけに月末出社するとかいう阿保な行為をしていますが…。

今後、書類の印鑑を電子で済ませるということも増えてきそうです。

個人的には「署名欄に名前を書くだけでよいのでは?」と思うのですが、どうしても印鑑にこだわる人も多いので、ExcelにVBAで印鑑が画像を挿入する方法を考えてみました。

印鑑に記載する名前の取得方法の検討

同じようなことを考えている人は多いようで「印鑑 VBA 作成」などで検索すると、解説サイトが沢山見つかります。

そのほとんどが、PC上に保存されている印鑑の画像をVBAでExcelに挿入するというものです。

しかし、これでは印鑑の画像を各個人ごとに作成して配布するのが手間だと思います。

そこで印鑑の画像を自動生成するところから始めたいのですが、問題は何処から名前を取得するかです。

パッと思いつくところだと以下の3つです。

  • officeのユーザ名から取得する
  • PCの名前から取得する
  • PCのログインユーザ名から取得する
  • PCの名前をもとにADをLDAP検索する
  • PCの名前をもとにOutLookのアドレス帳を検索する

これは、その組織がどのように名前を管理しているかにもよるので、現場ごとに名前の取れそうなところがどこか探すしかないですね。

方法はそれぞれ以下になるかと思います。

officeのユーザ名から取得する

Dim strUserName as String
strUserName  = Application.UserName

PCの名前から取得する

Dim ws As Object
Dim strUserName as String
Set ws = CreateObject("WScript.Network")

strUserName  = ws.ComputerName

Set ws = Nothing

PCのログインユーザ名から取得する

Dim ws As Object
Dim strUserName as String
Set ws = CreateObject("WScript.Network")

strUserName  = ws.UserName

Set ws = Nothing

PCの名前をもとにADをLDAP検索する

以下当たりの記事を参考に…

https://oshiete.goo.ne.jp/qa/9089776.html

PCの名前をもとにOutLookのアドレス帳を検索する

以下当たりの記事を参考に…

※本題ではないので、コードが面倒なところは他のブログの記事を参照にさせてもらいました。

印鑑オブジェクトを作成する

次にVBAで印鑑を作成していきます。まずは、下記のような印鑑の土台になるオブジェクトを作成する関数を作成します。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function

印鑑の丸の大きさは、「印鑑オブジェクトを作成する」の部分のAddShapeの引数で変更することができます。AddShapeは第3引数が横幅、第4引数が高さになっています。

印鑑の淵の線の太さが気に入らないとかいう場合は、「.Weight = 1」を指定している部分を「.Weight = 1.5」とかにすれば良いです。

これ以外にあまり変更したくなるところはなさそうかなあ。

ちなみに名前とか日付を入れる関数と別にしたのは、ドキュメントによって印鑑のデザインが違っても、この印鑑を作る部分は変わらない(使いまわせる)と思ったからです。


印鑑オブジェクトに名前と日時を挿入する

次に先ほど作成した印鑑のオブジェクトに名前と日付を自動入力して、本物の印鑑のような画像を作成します。以下のようなイメージです。

作成したコードは以下になります。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
    Call setName(sh, inkan, "田中", "承")
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function


Sub setName(sh As Worksheet, inkan As Object, strName As String, strTop As String)
    Dim shapeNames(0 To 5) As String
    shapeNames(0) = inkan.Name
    
    '印鑑の名前オブジェクトを作成
    Dim shapeName As Shape
    Set shapeName = CreateTextObj(sh, 55, strName)
    shapeNames(1) = shapeName.Name
    
    '印鑑の日付オブジェクトを作成
    Dim shapeDate As Shape
    Set shapeDate = CreateTextObj(sh, 30, Format(Now, "yyyy.mm.dd"))
    shapeNames(2) = shapeDate.Name
    
    '印鑑の最上部のテキストを作成
    Dim shapeTopText As Shape
    Set shapeTopText = CreateTextObj(sh, 0, strTop)
    shapeNames(3) = shapeTopText.Name
    
   '日付の上線を作成する
    Dim topLine As Object
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
    With topLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(4) = topLine.Name
    
    '日付の下線を作成する
    Dim underLine As Object
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30 )
    With underLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(5) = underLine.Name
    
    'グループ化する
   sh.Shapes.Range(shapeNames).Select
   Selection.ShapeRange.Group
End Sub

Private Function CreateTextObj(sh As Worksheet, offset As Integer, strText As String) As Shape
    'オブジェクトを作成
    Set CreateTextObj = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, 85, 30)
    
    'オブジェクトの線を消す
    CreateTextObj.Line.Visible = msoFalse
    'オブジェクトにテキストを入れる
    CreateTextObj.TextFrame2.TextRange.Characters.Text = strText
    CreateTextObj.TextFrame2.TextRange.Font.Size = 14
    
    'オブジェクトの背景消す
    CreateTextObj.Fill.Visible = msoFalse
    
    'オブジェクトのテキストを赤色にする
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    
    'オブジェクトのテキストを中央に寄せる
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
    
    'オブジェクトの位置を調整する
    CreateTextObj.IncrementTop offset
    
End Function

setNameという関数が名前と日付を入力している関数になります。この関数の引数は以下になっています。

第一引数:印鑑を挿入するワークシート

第二引数:印鑑オブジェクト

第三引数:印鑑に印字する名前

第四引数:印鑑の上段に表示する文字列(今回の場合は、”承”)

この第三引数の名前を前述したPCから取得できる名前などにすることで、各個人の固有の印鑑になります。

システム上、名前を取得することがどうしても難しい場合は、

  • 初回にExcelを開いたときに、InputBoxで名前を入力させる
  • 入力させた名前を非表示シートに記載しておく
  • その名前を取得して印鑑の名前に利用する

という方法もありな気がします。

印鑑オブジェクトを所定のセルに移動させる

ここまでで印鑑のオブジェクトを作成することはできたので、印鑑を所定の位置に移動させて終わりになります。

特定のセルに図形オブジェクトを移動させるのは以下のコードになります。

Public Sub setShapeToCell(obj As Shape, r As range)
   obj.Top = r.Top + r.Height / 2 - obj.Height / 2
   obj.Left = r.Left + r.Width / 2 - obj.Width / 2
End Sub

単純にセルの高さと左端にそろえると、図形オブジェクトがセルの左端に行ってしまいます。

今回の印鑑はセルの中央に配置したいので、セルの高さとセルの幅を取得してその半分の位置に移動させます。

しかし、それでも印鑑のオブジェクト自身の大きさ分ずれてしまうので、地震の大きさの半分の値を加算します。

ここまでの、まとめると以下のようになります。

Sub main()
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"

    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
    
    Dim inkan As Shape
    Set inkan = createInkanTemplate(sh)
    Call setName(sh, inkan, "田中", "承")
    
    '作成した印鑑をC10に移動させる
    Call setShapeToCell(Selection.ShapeRange(1), range("C10"))
    
End Sub

Function createInkanTemplate(sh As Worksheet) As Shape
    '印鑑を挿入するシート
    Const WORK_SHEET_NAME = "Sheet1"
    
    Dim inkan As Shape
    
    '印鑑オブジェクトを作成する
    Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
    
    '印鑑の淵の色を赤色に変更する
    With inkan.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    
    '印鑑の色を塗りつぶす
    With inkan.Fill
        .Visible = msoTrue
        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
        .ForeColor.TintAndShade = 0
        .ForeColor.Brightness = 0
        .Transparency = 0
        .Solid
    End With
    
    '印鑑に影をつける
    inkan.Shadow.Type = msoShadow24
    
    Set createInkanTemplate = inkan

End Function


Sub setName(sh As Worksheet, inkan As Object, strName As String, strTop As String)
    Dim shapeNames(0 To 5) As String
    shapeNames(0) = inkan.Name
    
    '印鑑の名前オブジェクトを作成
    Dim shapeName As Shape
    Set shapeName = CreateTextObj(sh, 55, strName)
    shapeNames(1) = shapeName.Name
    
    '印鑑の日付オブジェクトを作成
    Dim shapeDate As Shape
    Set shapeDate = CreateTextObj(sh, 30, Format(Now, "yyyy.mm.dd"))
    shapeNames(2) = shapeDate.Name
    
    '印鑑の最上部のテキストを作成
    Dim shapeTopText As Shape
    Set shapeTopText = CreateTextObj(sh, 0, strTop)
    shapeNames(3) = shapeTopText.Name
    
    '日付の上線を作成する
    Dim topLine As Object
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
    With topLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(4) = topLine.Name
    
    '日付の下線を作成する
    Dim underLine As Object
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30)
    With underLine.Line
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Weight = 1
    End With
    shapeNames(5) = underLine.Name
    
    'グループ化する
   sh.Shapes.range(shapeNames).Select
   Selection.ShapeRange.Group
End Sub

Private Function CreateTextObj(sh As Worksheet, offset As Integer, strText As String) As Shape
    'オブジェクトを作成
    Set CreateTextObj = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, 85, 30)
    
    'オブジェクトの線を消す
    CreateTextObj.Line.Visible = msoFalse
    'オブジェクトにテキストを入れる
    CreateTextObj.TextFrame2.TextRange.Characters.Text = strText
    CreateTextObj.TextFrame2.TextRange.Font.Size = 14
    
    'オブジェクトの背景消す
    CreateTextObj.Fill.Visible = msoFalse
    
    'オブジェクトのテキストを赤色にする
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).Font.Fill
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .Transparency = 0
        .Solid
    End With
    
    'オブジェクトのテキストを中央に寄せる
    With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).ParagraphFormat
        .FirstLineIndent = 0
        .Alignment = msoAlignCenter
    End With
    
    'オブジェクトの位置を調整する
    CreateTextObj.IncrementTop offset
    
End Function

Public Sub setShapeToCell(obj As Shape, r As range)
   obj.Top = r.Top + r.Height / 2 - obj.Height / 2
   obj.Left = r.Left + r.Width / 2 - obj.Width / 2
End Sub

印鑑オブジェクトの課題

課題としては、印鑑のオブジェクトのグループ化を解除されて無理やり名前を変更される可能性があるということですね。

少しExcelを触ったことがある人の場合は、画像のグループ化解除の操作もできると思うので、解除して名前を書き換えるということが可能になります。

その場合は、印鑑のオブジェクトをパスワード保護して、VBAプロジェクトのパスワードかけるしかないですかねえ。


8 件のコメント

  • 素晴らしいですね!

    例えばsetNameの第3引数は
    ユーザーフォームのtext内容から引用させることは可能なのでしょうか?

    • ありがとうございます。
      例で記載したmainの関数に引数を渡せるようにして、mainの関数をユーザーフォームから呼び出せるようにすればいけそうな気がします。

      Public Sub main(strName As String)
          '印鑑を挿入するシート
          Const WORK_SHEET_NAME = "Sheet1"
      
          Dim sh As Worksheet
          Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
          
          Dim inkan As Shape
          Set inkan = createInkanTemplate(sh)
          Call setName(sh, inkan, strName, "承")
          
          '作成した印鑑をC10に移動させる
          Call setShapeToCell(sh.Shapes.Range(shapeNames), Range("C10"))
          
      End Sub
      
      'ユーザーフォーム側のコード(第3引数を入力するのがTextBox1だった場合)
      Private Sub CommandButton1_Click()
          Call main(TextBox1.Text)
      End Sub
  • ‘日付の上線を作成する
    ‘日付の下線を作成する

    の所で変数の宣言が逆なのと変数を誤記しているため、オブジェクトのグループ化に失敗しています。

    ‘日付の上線を作成する
    Dim underLine As Object ‘←topLineの誤記
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55) ‘←Set topLineの誤記
    With underLine.Line ‘←topLine.Lineの誤記
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    .Weight = 1
    End With
    shapeNames(4) = underLine.Name ‘←topLine.Nameの誤記

    ‘日付の下線を作成する
    Dim topLine As Object ‘←underLineの誤記
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30) ‘←Set underLineの誤記
    With topLine.Line ‘←underLine.Lineの誤記
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    .Weight = 1
    End With
    shapeNames(5) = underLine.Name

  • マクロの動作的には問題無いのですが、topLineとunderLineの線を引く位置が逆だったので、念のため指摘させていただきます。

    ‘日付の上線を作成する
    Dim topLine As Object
    Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55) ‘←4, 30, 85, 30 (現状、topLine としてunderLine を引いています)

    ‘日付の下線を作成する
    Dim underLine As Object
    Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30) ‘←4, 55, 85, 55 (現状、underLineとしてtopLineを引いています)

    • ワークシート上にあるActiveX ComboBoxの値を取得して名前を設定する方法は以下のような感じでしょうか。

      ‘コンボボックスの名前
      Const CONBO_NAME1 = “ComboBox1”
      Const CONBO_NAME2 = “ComboBox2”
      Const CONBO_NAME3 = “ComboBox3”

      上記部分にコンボボックスの名前を設定しています。
      ComboBoxは、ワークシート上のフォームコントロールのComboBoxとかUserFormのComboBoxとか色々種類があり、それぞれで取得方法が異なるので意図していたものでなかったらすみません。

      Public Sub main()
          '印鑑を挿入するシート
          Const WORK_SHEET_NAME = "Sheet1"
          
          'コンボボックスの名前
          Const CONBO_NAME1 = "ComboBox1"
          Const CONBO_NAME2 = "ComboBox2"
          Const CONBO_NAME3 = "ComboBox3"
      
          Dim sh As Worksheet
          Set sh = ThisWorkbook.Worksheets(WORK_SHEET_NAME)
          
          '引数にコンボボックスの名前を指定する
          If getComboBoxValue(CONBO_NAME1) <> "" Then
              Dim inkan As Shape
              Set inkan = createInkanTemplate(sh)
              Call setName(sh, inkan, getComboBoxValue(CONBO_NAME1), "承")
          
              '作成した印鑑をC10に移動させる
              Call setShapeToCell(Selection.ShapeRange(1), Range("C10"))
          Else
              MsgBox CONBO_NAME1 + ":名前が選択されていません"
          End If
          
          '引数にコンボボックスの名前を指定する
          If getComboBoxValue(CONBO_NAME2) <> "" Then
              Dim inkan As Shape
              Set inkan = createInkanTemplate(sh)
              Call setName(sh, inkan, getComboBoxValue(CONBO_NAME2), "承")
          
              '作成した印鑑をC10に移動させる
              Call setShapeToCell(Selection.ShapeRange(1), Range("C10"))
          Else
              MsgBox CONBO_NAME2 + ":名前が選択されていません"
          End If
          
          '引数にコンボボックスの名前を指定する
          If getComboBoxValue(CONBO_NAME3) <> "" Then
              Dim inkan As Shape
              Set inkan = createInkanTemplate(sh)
              Call setName(sh, inkan, getComboBoxValue(CONBO_NAME3), "承")
          
              '作成した印鑑をC10に移動させる
              Call setShapeToCell(Selection.ShapeRange(1), Range("C10"))
          Else
              MsgBox CONBO_NAME3 + ":名前が選択されていません"
          End If
          
      End Sub
      
      Private Function getComboBoxValue(comboBoxName As String)
          Dim cb As OLEObject
          Set cb = ActiveSheet.OLEObjects(comboBoxName) ' コンボボックスを取得
          
          Dim selectedValue As String
          selectedValue = cb.Object.Value ' 選択された値を取得
          
          If selectedValue <> "" Then
              getComboBoxValue = selectedValue
          Else
              getComboBoxValue = ""
          End If
      End Function
      
      Private Function createInkanTemplate(sh As Worksheet) As Shape
          '印鑑を挿入するシート
          Const WORK_SHEET_NAME = "Sheet1"
          
          Dim inkan As Shape
          
          '印鑑オブジェクトを作成する
          Set inkan = sh.Shapes.AddShape(msoShapeOval, 1, 1, 85, 85)
          
          '印鑑の淵の色を赤色に変更する
          With inkan.Line
              .Visible = msoTrue
              .ForeColor.RGB = RGB(255, 0, 0)
              .Transparency = 0
              .Weight = 1
          End With
          
          '印鑑の色を塗りつぶす
          With inkan.Fill
              .Visible = msoTrue
              .ForeColor.ObjectThemeColor = msoThemeColorBackground1
              .ForeColor.TintAndShade = 0
              .ForeColor.Brightness = 0
              .Transparency = 0
              .Solid
          End With
          
          '印鑑に影をつける
          inkan.Shadow.Type = msoShadow24
          
          Set createInkanTemplate = inkan
      
      End Function
      
      
      Private Sub setName(sh As Worksheet, inkan As Object, strName As String, strTop As String)
          Dim shapeNames(0 To 5) As String
          shapeNames(0) = inkan.Name
          
          '印鑑の名前オブジェクトを作成
          Dim shapeName As Shape
          Set shapeName = CreateTextObj(sh, 55, strName)
          shapeNames(1) = shapeName.Name
          
          '印鑑の日付オブジェクトを作成
          Dim shapeDate As Shape
          Set shapeDate = CreateTextObj(sh, 30, Format(Now, "yyyy.mm.dd"))
          shapeNames(2) = shapeDate.Name
          
          '印鑑の最上部のテキストを作成
          Dim shapeTopText As Shape
          Set shapeTopText = CreateTextObj(sh, 0, strTop)
          shapeNames(3) = shapeTopText.Name
          
          '日付の上線を作成する
          Dim topLine As Object
          Set topLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 55, 85, 55)
          With topLine.Line
              .Visible = msoTrue
              .ForeColor.RGB = RGB(255, 0, 0)
              .Transparency = 0
              .Weight = 1
          End With
          shapeNames(4) = topLine.Name
          
          '日付の下線を作成する
          Dim underLine As Object
          Set underLine = sh.Shapes.AddConnector(msoConnectorStraight, 4, 30, 85, 30)
          With underLine.Line
              .Visible = msoTrue
              .ForeColor.RGB = RGB(255, 0, 0)
              .Transparency = 0
              .Weight = 1
          End With
          shapeNames(5) = underLine.Name
          
          'グループ化する
         sh.Shapes.Range(shapeNames).Select
         Selection.ShapeRange.Group
      End Sub
      
      Private Function CreateTextObj(sh As Worksheet, offset As Integer, strText As String) As Shape
          'オブジェクトを作成
          Set CreateTextObj = sh.Shapes.AddShape(msoShapeRectangle, 0, 0, 85, 30)
          
          'オブジェクトの線を消す
          CreateTextObj.Line.Visible = msoFalse
          'オブジェクトにテキストを入れる
          CreateTextObj.TextFrame2.TextRange.Characters.Text = strText
          CreateTextObj.TextFrame2.TextRange.Font.Size = 14
          
          'オブジェクトの背景消す
          CreateTextObj.Fill.Visible = msoFalse
          
          'オブジェクトのテキストを赤色にする
          With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).Font.Fill
              .Visible = msoTrue
              .ForeColor.RGB = RGB(255, 0, 0)
              .Transparency = 0
              .Solid
          End With
          
          'オブジェクトのテキストを中央に寄せる
          With CreateTextObj.TextFrame2.TextRange.Characters(1, Len(strText)).ParagraphFormat
              .FirstLineIndent = 0
              .Alignment = msoAlignCenter
          End With
          
          'オブジェクトの位置を調整する
          CreateTextObj.IncrementTop offset
          
      End Function
      
      Private Sub setShapeToCell(obj As Shape, r As Range)
         obj.Top = r.Top + r.Height / 2 - obj.Height / 2
         obj.Left = r.Left + r.Width / 2 - obj.Width / 2
      End Sub
  • コメントを残す

    メールアドレスが公開されることはありません。

    日本語が含まれない投稿は無視されますのでご注意ください。(スパム対策)