Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

40883 / 76732

←次へ　｜　前へ→


	【40938】Re:吹出しの先っぽの位置を変えずに自動サイズ調整してほしい

ichinose - 06/7/26(水) 16:11 -


	引用なし

	パスワード

こんにちは。
私のは試して頂きましたか？

位置を確保するにはAdjustmentsすべてを再設定してみては？

Option Explicit
'Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'コメントにしてありますが、これ入れるとＣＰＵの占有率が下がる
'=========================================================================
Sub ふきだし()
　　Dim vLeft, vtop, vHeight, vWidth As Long
　　Dim txt As String
　　Dim svx(1 To 3) As Double, svy(1 To 3) As Double
　　Dim svl As Double, svt As Double
　　With ActiveCell '位置調整
　　　　vLeft = .Left + .Width + 22
　　　　vtop = .Top - 15
　　　　vHeight = 10
　　　　vWidth = 50
　　End With
　　With ActiveSheet.Shapes.AddShape(msoShapeLineCallout3, vLeft, vtop, vWidth, vHeight)
　　　 .Fill.ForeColor.RGB = RGB(255, 204, 204)
　　　 With .Line
　　　　　.ForeColor.SchemeColor = 20
　　　　　.BeginArrowheadStyle = msoArrowheadOval
　　　　　.EndArrowheadStyle = msoArrowheadOval
　　　　　End With
　　　 svx(1) = Round((.Adjustments(1) * .Width + .Left) / 0.75, 0) * 0.75
　　　 svy(1) = Round((.Adjustments(2) * .Height + .Top) / 0.75, 0) * 0.75
　　　 svx(2) = Round((.Adjustments(3) * .Width + .Left) / 0.75, 0) * 0.75
　　　 svy(2) = Round((.Adjustments(4) * .Height + .Top) / 0.75, 0) * 0.75
　　　 svx(3) = Round((.Adjustments(5) * .Width + .Left) / 0.75, 0) * 0.75
　　　 svy(3) = Round((.Adjustments(6) * .Height + .Top) / 0.75, 0) * 0.75
'取り急ぎ記述しましたが↑は、ループでまとめられると思います。
　　　 '↑ポイント1は、この上記の式なにやっているか解読してね
　　　 svl = .Left
　　　 svt = .Top
　　　 With .TextFrame
　　　　　With .Characters
　　　　　　 .Text = ""
　　　　　　 With .Font
　　　　　　　　.Name = "ＭＳＰゴシック"
　　　　　　　　.Size = 8
　　　　　　　　End With
　　　
　　　　　　 End With
　　　　　End With
　　　 .Select
　　　 SendKeys " {BS}"
　　　 On Error Resume Next
　　　 Do While Selection.Name = .Name
　　　　　If Err.Number <> 0 Then Exit Do
　　　　　DoEvents
　　　　　'Sleep 100
'　　　　　これのコメントもはずして試してみてください
　　　　　Loop
　　　 On Error GoTo 0
　　　 .TextFrame.AutoSize = True
　　　 DoEvents
　　　 .Adjustments(1) = (svx(1) - .Left) / .Width
　　　 .Adjustments(2) = (svy(1) - .Top) / .Height
　　　 .Adjustments(3) = (svx(2) - .Left) / .Width
　　　 .Adjustments(4) = (svy(2) - .Top) / .Height
　　　 .Adjustments(5) = (svx(3) - .Left) / .Width
　　　 .Adjustments(6) = (svy(3) - .Top) / .Height
'　　　　↑ポイント2は、上記の式で自動サイズ調整後に再設定しています。
　　　 End With
End Sub

尚、これの使用方法は、実行後、文字入力したのち、セルを選択すれば
吹き出し位置の再設定が行われます。

0 hits

▼

【40680】吹出しの先っぽの位置を変えずに自動サイズ調整してほしい あくたいおん 06/7/20(木) 13:01