リストから吹き出しオートシェイプ作成
'*** ﾒｲﾝ ********************************************************
'リストから吹き出しを作成する
Sub mkFukidasi()
Dim lastrow As Integer, i As Integer
lastrow = getActiveRows()
For i = 1 To lastrow
If (matchPatternCell("^1-1-[0-9]+$", getCellValue("A", i))) Then
Call mkAutoShape(Trim(getCellValue("A", i) & " " & getCellValue("B", i)), 100, 100 + i * 20)
End If
Next
End Sub
'*** /ﾒｲﾝ ********************************************************
'*** ｻﾌﾞ ********************************************************
'指定セルの値を取得
'@param string x 列
'@param int y 行
'@return string セルの値
Function getCellValue(x As String, y As Integer) As String
getCellValue = Range(x & y).value
End Function
'アクティブな最後の行を返す
'@return int
Function getActiveRows() As Integer
Dim lastrow As Integer
With ActiveSheet.UsedRange
getActiveRows = .Cells(.Count).row
End With
End Function
'正規表現にマッチしていればtrueを返す
'@param string buf 検索対象文字列
'@return bool
Function matchPatternCell(patt As String, buf As String) As Boolean
Dim re As RegExp
Set re = New RegExp
re.Pattern = patt '数字のみの文字列を表す正規表現
matchPatternCell = re.Test(buf)
End Function
' オートシェイプ噴出し作成
Sub mkAutoShape(value As String, x As Integer, y As Integer)
'サイズ横を生成する
Dim ByteCount As Long '文字列のバイト数
ByteCount = LenB(StrConv(value, vbFromUnicode))
'vbLFで分割する
Dim strArray() As String
strArray = Split(value, vbLf)
Dim z As Integer
Dim sizeX As Integer
'行数
Dim rows As Integer
rows = UBound(strArray)
For z = 0 To rows
If (sizeX < getObjSizeX(strArray(z))) Then sizeX = getObjSizeX(strArray(z))
Next
'(タイプ,ｘ座標,ｙ座標,サイズ横,サイズ縦)
ActiveSheet.Shapes.AddShape(msoShapeLineCallout2, x, y, sizeX, 12 + rows * 12).Select
Selection.Characters.Text = value
With Selection.Characters.Font
.Name = "ＭＳ Ｐゴシック"
.FontStyle = "標準"
.Size = 9
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.Visible = msoTrue
End Sub
'文字列からサイズ横を返す
'@param string value 対象文字列
'@return int サイズ横
Function getObjSizeX(value As String) As Integer
Dim K As Long
Dim s As String
Dim sizeX As Integer
For K = 1 To Len(value)
s = Mid(value, K, 1)
If 0 <= Asc(s) And Asc(s) <= 255 Then
sizeX = sizeX + 5
Else
sizeX = sizeX + 9
End If
Next K
getObjSizeX = sizeX
End Function
'*** /ｻﾌﾞ ********************************************************
