| |
▼あくたいおん さん：
こんにちは。
Sendkeysは、動作が不安定な場合がありますから、
よくよくデバッグを繰り返してください。
Windowsによっても違うかもしれませんよ！！
このサイトで私が大変、お世話になったJuJuさんという方の
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=5831;id=excel
この投稿が私には、強く印象に残っていますし、
私自身も何度かSendkeysではうまく作動しない事例を経験したことがあります。
よって、再度私なら、「Sendkeysではなく、Inputboxやユーザーフォームで
テキストは入力させる」という仕様にするだるだろうなあ
ということをお断りして・・・。
'=====================================================================
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 As Double, svy 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 = Round((.Adjustments(1) * .Width + .Left) / 0.75, 0) * 0.75
svy = Round((.Adjustments(2) * .Height + .Top) / 0.75, 0) * 0.75
'↑ポイント1は、この上記の式なにやっているか解読してね
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
.Adjustments(1) = (svx - .Left) / .Width
.Adjustments(2) = (svy - .Top) / .Height
' ↑ポイント2は、上記の式で自動サイズ調整後に再設定しています。
End With
End Sub
後は、Autosize=Trueをどこで設定するかも仕様として決めなければなりませんね！！
|
|
ichinose
- 06/7/21(金) 17:31 -
