Visual Basic 中学校 掲示板 投稿内容
タグのない投稿を抽出 統計 RSS

Visual Basic 中学校 > 投稿一覧 >

inkpictureでdeleteすると、他のstrokeのインデックスなどが配列から無くなります

タグの編集...

投稿者 snowmansnow   (社会人)   投稿日時 2021/2/23 18:43:39
こんにちは、るきお様、魔界の仮面弁士様、ニケ様、皆様、
またVBAのinkpictureで質問があります

段落、行、単語に分けて四角で囲む例がwebであったので、移植してみました。
webの例では、グラフィックで四角を描画していましたが、やり方がわからず(render?)
strokeの色変えで描画してみました。
その後で、文字の黒色以外の色のstrokeを配列にして、削除するボタンを作ったつもりでしたが、
複数の削除の1回目以降で、配列の中身(strokeのインデックス)が失われるようでした。
for each 〇〇 in strokesの中身を回していますが、〇〇の型がわからず、as objectにしています。
〇〇にかかわるdeleteをすると、他の〇〇.idの全部の値が失われるのでしょうか?
msgboxで配列の値を表示すると、1回目の削除まで値を保持して、削除後、他の値を失ってるように見えます。

フォームに大きなinkpicture2と小さなinkpicture3、inkpicture4を配置して
「四角で囲むボタン」CommandButton36と、「削除のボタン」CommandButton37を配置して、
大きなinkpicture2に、横書きで3行くらい記入して、
inkpicture3、inkpicture4に一文字ずつくらい記入してボタンを押します。

最初、削除が悪さをしてると思い、逆に黒いstrokeを追加していくバージョンも検討したので、
このような形になっていますが、配列が悪さをしてるようなので、どちらもダメだと思います。
配列が直れば、削除型でも追加型でも出来る気がします。

①グラフィック(render?)で描画する。
②配列の値を失わないやり方。
③その他
など、御教授いただけるとありがたいです。
よろしくお願いいたします。


Private Sub CommandButton36_Click()

'https://microsoft.public.windows.tabletpc.developer.narkive.com/05mR9JoA/bounding-box-of-individual-words-in-inkpicture
Dim div As InkDivider
Dim divUnits As IInkDivisionUnits
Dim paras As IInkDivisionUnits
Dim lines As IInkDivisionUnits
Dim segments As IInkDivisionUnits

Dim divUnit As IInkDivisionUnit
Dim para As IInkDivisionUnit
Dim line As IInkDivisionUnit
Dim segment As IInkDivisionUnit

Set div = New InkDivider
Set div.strokes = InkPicture2.ink.strokes
Set res = div.Divide()

Set paras = div.Divide.ResultByType(IDT_Paragraph)
Set lines = div.Divide.ResultByType(IDT_Line)
Set segments = div.Divide.ResultByType(IDT_Segment)

'https://docs.microsoft.com/en-us/windows/win32/api/msinkaut15/ne-msinkaut15-inkdivisiontype
'Name    Description
'IDT_Segment A recognition segment.
'IDT_Line    A line of handwriting that contains one or more recognition segments.
'IDT_Paragraph   A block of strokes that contains one or more lines of handwriting.
'IDT_Drawing Ink that is not text.

Dim rect1 As InkRectangle

   Dim strokes(1) As IInkStrokeDisp
For Each para In paras
    Set rect1 = para.strokes.GetBoundingBox(IBBM_Default)
     
     With InkPicture2.ink
        Set strokes(0) = .CreateStroke(MakeRectangle(rect1.left - 2, rect1.top + 4, rect1.right + 4, rect1.bottom - 2), Null)
     End With
    
         With strokes(0).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = RGB(0, 0, 255)
        End With
 Next
For Each line In lines
    Set rect1 = line.strokes.GetBoundingBox(IBBM_Default)
     
      With InkPicture2.ink
        Set strokes(0) = .CreateStroke(MakeRectangle(rect1.left, rect1.top, rect1.right, rect1.bottom), Null)
     End With
    
         With strokes(0).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = 255
        End With
 Next
For Each segment In segments
    Set rect1 = segment.strokes.GetBoundingBox(IBBM_Default)
     
     With InkPicture2.ink
        Set strokes(0) = .CreateStroke(MakeRectangle(rect1.left + 2, rect1.top + 2, rect1.right - 4, rect1.bottom + 2), Null)
     End With
    
         With strokes(0).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = RGB(0, 128, 0)
        End With
 Next

    InkPicture2.AutoRedraw = False
    With InkPicture2.ink.CreateStrokes()
            .Add strokes(0)
    End With
    InkPicture2.AutoRedraw = True

    
End Sub
Private Function MakeRectangle(left As Long, top As Long, right As Long, bottom As Long) As Long()
'http://www.vbforums.com/showthread.php?763319-Drawing-shapes-on-ink-picture
    Dim Coords() As Long
    ReDim Coords(9)
        Coords(0) = left
        Coords(1) = top
        Coords(2) = right
        Coords(3) = top
        Coords(4) = right
        Coords(5) = bottom
        Coords(6) = left
        Coords(7) = bottom
        Coords(8) = left
        Coords(9) = top
    MakeRectangle = Coords
End Function
Private Sub CommandButton38_Click()

文字制限のため、問題の削除部分は追加投稿いたします

投稿者 snowmansnow   (社会人)   投稿日時 2021/2/23 18:45:20
文字制限のため、追加投稿いたします。
問題の削除の部分です


Private Sub CommandButton37_Click()
 Dim myStroke As Object
 Dim c As Variant
     Dim dels() As Long
   
    ReDim dels(0)
    MsgBox InkPicture2.ink.strokes.Count
   For Each myStroke In InkPicture2.ink.strokes
    If InkPicture2.ink.strokes(myStroke.id - 1).DrawingAttributes.Color <> 0 Then
    ReDim dels(UBound(dels) + 1)
     dels(UBound(dels) - 1) = myStroke.id
    MsgBox (UBound(dels)) & "-" & dels(UBound(dels) - 1)
    Else
    End If
 Next
    InkPicture2.AutoRedraw = True
    MsgBox (UBound(dels))

   Dim strokesd As IInkStrokeDisp
   
   Dim strokesToDelete As MSINKAUTLib.InkStrokes
  
   Set strokesToDelete = InkPicture2.ink.CreateStrokes()

   For d = (UBound(dels) - 1) To 1 Step -1
 '  Set strokesd = InkPicture2.ink.strokes(10)
    MsgBox d & "=" & dels(d)
 '  InkPicture2.ink.strokes.Remove strokesd
   InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes(29)
   InkPicture2.AutoRedraw = True
  Next

'インクを足す事はできる・・・
Dim strokes As MSINKAUTLib.InkStrokes
Set combinedInk = InkPicture2.ink
Set strokes = InkPicture3.ink.strokes
iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
Set strokes = InkPicture4.ink.strokes
iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
'https://microsoft.public.windows.tabletpc.developer.narkive.com/xeodljDK/rendering-ink-from-multiple-inkpictures-in-the-same-form


InkPicture2.AutoRedraw = True

End Sub

よろしくお願いします



投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/2/23 19:30:49
コードの内容は全く読み取っていないのですが、
> ReDim dels(UBound(dels) + 1)

For Each ループ内で繰り返し行うというのであれば、
Preserve キーワード付きで ReDim する必要があるのでは。

もしくは 配列の代わりに VBA.Collection を使うとか。

投稿者 snowmansnow   (社会人)   投稿日時 2021/2/23 20:52:49
魔界の仮面弁士様、大変ありがとうございます。
プリザーブを修正してみましたところ、1回目は動くようになりました。

でも、2回目やってみると、「実行時エラー5。プロシジャーの呼び出し、または引数が不正です」
になってしまいます。(下記の場所)
前回教えてもらった、シート上にストロークデータを記載する。をやってみると、st.idが飛んでいます。
何かリフレッシュみたいに、連番に戻す命令があるのでしょうか?
他に何か理由があるのでしょうか?
よろしくお願いします。


修正版
Private Sub CommandButton37_Click()
 Dim myStroke As Object
 Dim c As Variant
     Dim dels() As Long
   
    ReDim dels(0)
 '   MsgBox InkPicture2.ink.strokes.Count
   For Each myStroke In InkPicture2.ink.strokes
    If InkPicture2.ink.strokes(myStroke.id - 1).DrawingAttributes.Color <> 0 Then ・・・ここでエラー
    ReDim Preserve dels(UBound(dels) + 1)
     dels(UBound(dels) - 1) = myStroke.id
 '   MsgBox (UBound(dels)) & "-" & dels(UBound(dels) - 1)
    Else
    End If
 Next
    InkPicture2.AutoRedraw = True
 '   MsgBox (UBound(dels))

   Dim strokesd As IInkStrokeDisp
   
   Dim strokesToDelete As MSINKAUTLib.InkStrokes
  
   Set strokesToDelete = InkPicture2.ink.CreateStrokes()

   For d = (UBound(dels) - 1) To 0 Step -1
 '  Set strokesd = InkPicture2.ink.strokes(dels(d) - 1)
  '  MsgBox d & "=" & dels(d)
  ' InkPicture2.ink.strokes.Remove strokesd
'    InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes(30)
  InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes(dels(d) - 1)
   InkPicture2.AutoRedraw = True
  Next

'インクを足す事はできる・・・
'Dim strokes As MSINKAUTLib.InkStrokes
'Set combinedInk = InkPicture2.ink
'Set strokes = InkPicture3.ink.strokes
'iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
'Set strokes = InkPicture4.ink.strokes
'iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
'https://microsoft.public.windows.tabletpc.developer.narkive.com/xeodljDK/rendering-ink-from-multiple-inkpictures-in-the-same-form


InkPicture2.AutoRedraw = True

End Sub


投稿者 snowmansnow   (社会人)   投稿日時 2021/2/23 22:50:28
こんばんは、
2回目のエラーが頻発し、頭がこんがらがってましたが、
idが変わっても、カウントは変わらなかったので、頭を切り替えて、下記に変更してみたら動きました。

今回は、同じstroke群の中で色で、文字とグラフィックを区別してるのですが、
何か、MSINKAUTLib.inkrendererの中のdrawstrokeとかが、グラフィックなのかなぁ?と思ってます。
(cifies the strokes to draw using the given Graphics object or device context.)と書いていて、
デバイスコンテキスト?Graphic g とかの事かな?とか思ってまして、
簡単なヒントというかアドバイス(違うよとか、それだよとか)頂けたら、また頑張れる気がします。
よろしくお願いします。

再修正版
Private Sub CommandButton37_Click()
 
    For ind = InkPicture2.ink.strokes.Count - 1 To 0 Step -1
    If InkPicture2.ink.strokes.Item(ind).Deleted = False Then
 '   MsgBox "id-" & ind & "-" & InkPicture2.ink.strokes.Item(ind).DrawingAttributes.Color
  
    If InkPicture2.ink.strokes.Item(ind).DrawingAttributes.Color <> 0 Then
    
   InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes.Item(ind)
    
    Else
    End If
    Else
    End If
 Next
    InkPicture2.AutoRedraw = True

'インクを足す事はできる・・・
'Dim strokes As MSINKAUTLib.InkStrokes
'Set combinedInk = InkPicture2.ink
'Set strokes = InkPicture3.ink.strokes
'iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
'Set strokes = InkPicture4.ink.strokes
'iret = combinedInk.AddStrokesAtRectangle(strokes, strokes.GetBoundingBox())
'https://microsoft.public.windows.tabletpc.developer.narkive.com/xeodljDK/rendering-ink-from-multiple-inkpictures-in-the-same-form

End Sub


投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/2/23 23:34:51
最初の質問では、
 InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes(29)
のように固定値 29 に対して DeleteStroke していたのに対し、今回は
 InkPicture2.ink.DeleteStroke InkPicture2.ink.strokes(dels(d) - 1)
のような変動値にしているのですね?


今回の場合、Strokes プロパティから得られる InkStrokes コレクションに渡す引数が
間違っています。InkStrokes コレクションに対しては
 .strokes( Id )
ではなく
 .strokes( Index )
が求められます。
Id と Index は全く別物であることに気を付けましょう。


> やってみると、st.idが飛んでいます。
Index は連番を保証しますが、ストロークの Id は連番を保証するものではありません。

ストロークが削除されたとしても、各ストロークの Id は変化しませんが、
ストロークが削除されると、それ以降のストロークの Index は減少するためです。

それゆえ、ストロークの追加・削除によって、Index と Id の組み合わせが変化することになります。


たとえば、3 本のストロークがあって、
 InkPicture1.Ink.InkPicture1.Ink.Strokes(0).Id が 1
 InkPicture1.Ink.InkPicture1.Ink.Strokes(1).Id が 2
 InkPicture1.Ink.InkPicture1.Ink.Strokes(2).Id が 3
となっているときに、
 InkPicture1.Ink.DeleteStroke InkPicture1.Ink.Strokes(Index:=1)
を実行すれば、
 InkPicture1.Ink.InkPicture1.Ink.Strokes(0).Id が 1
 InkPicture1.Ink.InkPicture1.Ink.Strokes(1).Id が 3
という状態になるわけです。


> dels(UBound(dels) - 1) = myStroke.id
今回のケースでは、Id の一覧を管理している点を見直すべきでしょう。
処理として必要なのは、Id や Index ではなく、Stroke オブジェクトそのもののはずです。

ですから、 Id や Index を 「As Long な配列」として管理するのではなく、
それぞれのストロークそのものを「As IInkStrokeDisp な配列」、または
「As VBA.Collection な汎用コレクション」あるいは
「As InkDisp な別インクコレクション」などで管理しておく方が、手っ取り早いのではないでしょうか。

あるいは、複数ストロークの「一括削除」などが目的であれば、戻したい状態のストロークを
バイナリデータとして変数もしくはファイルに保持しておき、リロードするという手もあります。

Option Explicit
Private SavedStrokes() As Byte

Private Sub CommandButton1_Click()
    '現在のストロークをバイナリとして保持 
    SavedStrokes = InkPicture1.Ink.Save()
End Sub

Private Sub CommandButton2_Click()
    '保持しておいたストロークを復元 
    Dim newInk As InkDisp
    Set newInk = New InkDisp
    newInk.Load SavedStrokes
    
    InkPicture1.InkEnabled = False
    Set InkPicture1.Ink = newInk
    InkPicture1.InkEnabled = True
End Sub



> プリザーブを修正してみましたところ、1回目は動くようになりました。
今回のケースに限りませんが、ループ内で毎回 ReDim Preserve するような
コーディングはあまり好ましくありません。Preserve の回数は最小限に留めましょう。

現在のストローク総数は .Count で得られるので、最初に一回だけ
総数分の領域を ReDim で確保しておけば、ループ内で毎回
ReDim Preserve しなおす必要はないと思いますよ。

まぁ、件数が少ない場合はさほど問題になりませんが…。
https://vbabeginner.net/redim-preserve-really-slow/

投稿者 snowmansnow   (社会人)   投稿日時 2021/2/24 00:14:05
こんばんは、魔界の仮面弁士様
忙しい中、お時間割いて頂き、お返事ありがとうございます。

頭がこんがらがっていた時、
るきお様の別件のinkpicture.refresh()も試して、vbaではエラーになって、余計こんがらがったり、
Set newInk = New InkDisp
    newInk.Load ~~の
'https://stackoverflow.com/questions/3960729/how-to-erase-or-reload-strokes-to-an-inkpicture-in-vba-for-ms-access
を見つけても、vbaで実現できずに、煮詰まったりしていました。
今回バイナリセーブの例を出して頂いて、スッキリしました。
preserveの御指摘も端的で、総数を.countで取得も、全くその通りでした。

宜しければ、inkpictureで、線画など描画のヒント(背景も読めないし、出来ない旨のwebもありました)を頂ければ、ありがたいです。

今回の3つのboundingboxに加えて、GetStrokesFromTextRangeを順に調べたら、文字単位のboundingboxが取得出来るかな?と、思っています。(日本語)
でも、英語の筆記体は、文字に区別できなさそうで、どうやったら良いのかな?と思っています。
nodeとかleafとかいうものが、それに当たるのかな?とか困っています。
やってみて、また分からない所など、お聞きしますので、御教授お願いしたいです。
よろしくお願いします。



投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/2/24 00:28:58
ソースを貼る場合には、 CODE ブロックタグを併用して頂けると読みやすいです。
http://rucio.cloudapp.net/Usage.aspx


> 何か、MSINKAUTLib.inkrendererの中のdrawstrokeとかが、グラフィックなのかなぁ?と思ってます。

質問の意図が良く分かりませんが、DrawStroke メソッドは単一ストローク単位の描画、
Draw メソッドは複数のストローク群の描画にあたりますね。

InkRenderer オブジェクトの Draw メソッドの簡易サンプルを載せておきます。
現在のストロークの内容をデスクトップに転写するものです。

Option Explicit
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Sub CommandButton1_Click()
    Dim r As IInkRenderer
    Set r = New InkRenderer
    Dim hDC As LongPtr
    hDC = GetDC(0)
    r.Draw hDC, InkPicture1.Ink.Strokes
    ReleaseDC 0, hDC
End Sub



> (cifies the strokes to draw using the given Graphics object or device context.)と書いていて、
「Specifies the strokes」なのに、クリップボードにコピーすると
「cifies the strokes」に化けてしまう現象が出ますね…? なんだろう。

それはさておき:
InkRenderer オブジェクトの Draw メソッドや DrawStroke メソッドは、
第二引数で指定したストローク(InkStrokes or IInkStrokeDisp) の内容を
第一引数に指定したデバイス コンテキスト ハンドルに描画する処理です。
https://docs.microsoft.com/en-us/windows/win32/api/msinkaut/nf-msinkaut-iinkrenderer-drawstroke
https://docs.microsoft.com/en-us/windows/win32/api/msinkaut/nf-msinkaut-iinkrenderer-draw

VB6 だと、hDC プロパティでデバイス コンテキストのハンドルを得られますが、
VBA だとそれが無いので、API を使ってハンドルを得る必要があるでしょう。
https://excel.syogyoumujou.com/memorandum/get_dc.html

投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/2/24 01:52:41
> vbaで実現できずに、煮詰まったりしていました。
> 今回バイナリセーブの例を出して頂いて、スッキリしました。
Save & Load の例として、昨年書いていたこのあたりも。
http://rucio.cloudapp.net/ThreadDetail.aspx?ThreadId=30478


> 線画など描画のヒント(背景も読めないし、出来ない旨のwebもありました)を頂ければ、ありがたいです。
すでに
 https://www.vbforums.com/showthread.php?763319-Drawing-shapes-on-ink-picture
を利用したコードを書かれているようなので、ストロークの扱いは省くとして。

既存の画像を読み込むなら、LoadPicture を使えます。
Set InkPicture1.Picture = LoadPicture("C:\Windows\Web\Wallpaper\Theme1\img1.jpg")

あとは GDI API を使って、デバイス コンテキストに対して直接描画することもできます。
Private Declare PtrSafe Function Ellipse Lib "gdi32" (ByVal hDC As LongPtr, ByVal Left As LongByVal Top As LongByVal Right As LongByVal Bottom As LongAs Long
Private Sub InkPicture1_Painting(ByVal hDC As LongByVal Rect As MSINKAUTLib.IInkRectangle, Allow As Boolean)
    Ellipse hDC, Rect.Left + 5, Rect.Top + 5, Rect.Right - 5, Rect.Bottom - 5
End Sub


投稿者 snowmansnow   (社会人)   投稿日時 2021/2/24 21:46:16
こんばんは魔界の仮面弁士様
全ての疑問にお答え頂きありがとうございます。嬉しすぎて、お時間申し訳ないです。

でも早速InkRenderer オブジェクトの Draw メソッドの簡易サンプルを今回に使わせて頂こうと思ったのですが、デバイスコンテキストが違うのか、多少ズレてしまい、下記コード(※2)
るきお様の例を使って、ウィンドウのハンドルを使おうと思うと(※1) 
Draw メソッドが消えない。(リリースできない?)ようでした。
特に変な事はしていないと思うのですが、何が悪いのでしょうか?

文字のストロークはそのままで、一時InkPicture(inkP)にBoundingbox分のストロークを入れて、InkRendererで一時ストロークをDrawさせて、重ね合わせて表示させようとしました。
Private Sub CommandButton44_Click()

 Dim inkP As New MSINKAUTLib.InkPicture 'これが一時InkPicture 
 
'InkP.InkEnabled = True 
'https://microsoft.public.windows.tabletpc.developer.narkive.com/05mR9JoA/bounding-box-of-individual-words-in-inkpicture 
Dim div As InkDivider
Dim divUnits As IInkDivisionUnits

Dim paras As IInkDivisionUnits
Dim lines As IInkDivisionUnits
Dim segments As IInkDivisionUnits

Dim divUnit As IInkDivisionUnit
Dim para As IInkDivisionUnit
Dim line As IInkDivisionUnit
Dim segment As IInkDivisionUnit

Set div = New InkDivider
Set div.strokes = InkPicture2.ink.strokes
Set res = div.Divide()

Set paras = div.Divide.ResultByType(IDT_Paragraph)
Set lines = div.Divide.ResultByType(IDT_Line)
Set segments = div.Divide.ResultByType(IDT_Segment)

'https://docs.microsoft.com/en-us/windows/win32/api/msinkaut15/ne-msinkaut15-inkdivisiontype 
'Name    Description 
'IDT_Segment A recognition segment. 
'IDT_Line    A line of handwriting that contains one or more recognition segments. 
'IDT_Paragraph   A block of strokes that contains one or more lines of handwriting. 
'IDT_Drawing Ink that is not text. 

Dim rect1 As InkRectangle

   Dim strokes(4) As IInkStrokeDisp
For Each para In paras
    Set rect1 = para.strokes.GetBoundingBox(IBBM_Default)
     
    inkP.InkEnabled = False
 
       Set strokes(1) = inkP.ink.CreateStroke(MakeRectangle(rect1.Left - 2, rect1.Top + 4, rect1.Right + 4, rect1.Bottom - 2), Null)
    
         With strokes(1).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = RGB(0, 0, 255)
        End With
 Next
For Each line In lines
    Set rect1 = line.strokes.GetBoundingBox(IBBM_Default)
     
      With inkP.ink
        Set strokes(2) = .CreateStroke(MakeRectangle(rect1.Left, rect1.Top, rect1.Right, rect1.Bottom), Null)
     End With
    
         With strokes(2).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = 255
        End With
 Next
For Each segment In segments
    Set rect1 = segment.strokes.GetBoundingBox(IBBM_Default)
     
     With inkP.ink
        Set strokes(3) = .CreateStroke(MakeRectangle(rect1.Left + 2, rect1.Top + 2, rect1.Right - 4, rect1.Bottom + 2), Null)
     End With
    
         With strokes(3).DrawingAttributes
            .FitToCurve = IsCircle
            .Color = RGB(0, 128, 0)
        End With
 Next

    inkP.AutoRedraw = False
    With inkP.ink.CreateStrokes()
            .Add strokes(1)
            .Add strokes(2)
            .Add strokes(3)
    End With
   inkP.AutoRedraw = True

Dim hTargetWin As Long    '対象のウィンドウのハンドル 

hTargetWin = WindowFromPoint(0, 0)

'http://rucio.a.la9.jp/main/tyukyu/tyukyu5.htm 
    Dim r As IInkRenderer
    Set r = New InkRenderer
    Dim hDC As LongPtr
'   hDC = GetDC(hTargetWin)     '※1 
    hDC = GetDC(0)              '※2 
    r.Draw hDC, inkP.ink.strokes
'    ReleaseDC hTargetWin, hDC  '※1 
     ReleaseDC 0, hDC          '※2 

End Sub



投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/2/27 11:10:15
> でも早速InkRenderer オブジェクトの Draw メソッドの簡易サンプルを今回に使わせて頂こうと思ったのですが、

InkRenderer は、インクをオーバーレイ表示するために使うものだと思いますが、
これを使う目的は何でしょうか。座標変換は使わず、単に転記するのみ?

Draw メソッドを使うとなると、ジェスチャーの軌跡などの一時的な描画であればさておき、
複数のストロークを永続表示しようとするならば、ボタン押下時ではなく、
WM_PAINT メッセージを捉えて随時描画し続けるコードを用意する必要があると思います。


> デバイスコンテキストが違うのか、
何に対して描画することを目的としていますか?
ビットマップファイル? プリンター? ディスプレイ? ウィンドウ?

どのデバイスのどのレイヤーに描画するのかによって、
デバイスコンテキストハンドルの取得方法も変わってきますし、
ウィンドウのクライアント領域に描画することを目的としているのであれば、
高DPIへの考慮が必要になる消すもあるかもしれません。

> 多少ズレてしまい、
どの座標に描画しようとしているのでしょうか。
また、そのずれの量は具体的には如何ほどですか?

> Draw メソッドが消えない。(リリースできない?)ようでした。
メソッドが消える…? ごめんなさい、質問の意味を理解できませんでした。

投稿者 snowmansnow   (社会人)   投稿日時 2021/2/28 16:59:40
こんにちは、魔界の仮面弁士様
なかなかうまくいかず、遅くなってしまい、申し訳ございません。

①座標変換は、出来るようになりました。(下記)
  他の方々がやっているように、重ね合わせがしたかったです。
  何か触ると消えてしまいますが、触らなければ、追加情報が手に入るから。と思っております。
  WM_PAINT メッセージは、面白そうだなぁと思いましたが、
   VBAでの使い方がわからず、また、その後の対策?(再描画?)もわからなそうでした。

②今回は、たぶん、form1を取得してると思うのですが、strokeの座標系は、inkpicture2だと思われるので、
  上部タイトルや、左枠線分ずれていると思われます。
  inkpicture2のデバイスコンテキストが取得できるのか、わからないですし、
  将来、他のアプリ?などに、重ね合わせて、転記して表示する、DCの取得方法もわかりません。

③ズレは、私の環境の、ストローク座標で、目検offsetX = 390、offsetY = 1020だと思われました。

④ReleaseDC 0, hDCだと、重ね合わせは消えるのですが、
 ReleaseDC hTargetWin, hDCだと、重ね合わせが消えない事を表現しようと思いました。
 それを、「Draw メソッドが消えない。(リリースできない?)ようでした。」と記載しました。

 ①は、出来るようになりましたので、他の方用にコードを記載いたします。
   
  アトリビュートのコピーがうまくいってなくて、
  下記の前のバージョン(createstrokeなど)では、boundingboxが、丸くなる症状が出てしまってましたが、
  今回は、うまくコピーできてるようでした。

 前回、言葉足らずだったり、表現が悪く申し訳ございませんでした。
 あきれずに、また宜しくお願いします。

Private Sub CommandButton46_Click()

Dim inkP As New MSINKAUTLib.InkPicture
Dim strokesm As MSINKAUTLib.InkStrokes
Dim offsetX As Single
Dim offsetY As Single

offsetX = 390
offsetY = 1020

Set combinedInk = inkP.ink

Set strokesm = InkPicture2.ink.strokes
iret = combinedInk.AddStrokesAtRectangle(strokesm, strokesm.GetBoundingBox())
inkP.ink.strokes.Move offsetX, offsetY
inkP.AutoRedraw = True

  For st = 0 To InkPicture2.ink.strokes.Count - 1
  Set inkP.ink.strokes.Item(st).DrawingAttributes = InkPicture2.ink.strokes.Item(st).DrawingAttributes
  Next
   Dim r As IInkRenderer
    Set r = New InkRenderer
    Dim hDC As LongPtr
    hDC = GetDC(0)
    r.Draw hDC, inkP.ink.strokes
     ReleaseDC 0, hDC

End Sub








投稿者 snowmansnow   (社会人)   投稿日時 2021/3/21 22:53:55
こんばんは、るきお様、仮面の魔界弁士様
WM_PAINTは、うまくいかなったですが、WM_PAINTで再描画できました。
るきお様のvb6を参考にVBA用に変更しました。
標準モジュール

'http://rucio.o.oo7.jp/main/tyukyu/tyukyu9.htm 


'□API関数 
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongByVal nIndex As LongByVal dwNewLong As LongAs Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongByVal hwnd As LongByVal MSG As LongByVal wParam As LongByVal lParam As LongAs Long

Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long

Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" _
       (ByVal hwnd As LongByVal lpClassName As StringByVal nMaxCount As LongAs Long

'□SetWindowLongで使用 
Private Const GWL_WNDPROC = -4

'□メッセージ 
Private Const WM_CONTEXTMENU = &H7B '右クリックWM_PAINT 
Private Const WM_PAINT = &HF       'ウィンドウを再描画する必要がある 
Private Const WM_MOVE = &H3       'ウィンドウ移動 

'□コレクション すべてウィンドウハンドルがキー 
Dim colDProc As Collection '現在サブクラス化されているコントロールの元のWindowsProcのアドレス 

Public sy As Long
Public sx As Long
Public ny As Long
Public nx As Long


'■WindowProc 
'■機能:メッセージを横取りする。 
'■備考:この関数はコールバック関数なので定義を変えてはいけない! 
Public Function WindowProc(ByVal hwnd As LongByVal uMsg As LongByVal wParam As LongByVal lParam As LongAs Long

    Dim DefaultProc As Long
    Dim c As Long

    Select Case uMsg

        Case WM_PAINT 'ウィンドウを再描画する必要がある 
        UserForm1.Label11.Caption = c
        c = c + 1
            Exit Function
      
       'https://oshiete.goo.ne.jp/qa/4620863.html 
       Case WM_MOVE 'ウィンドウを再描画する必要がある 
         
        UserForm1.Label4.Caption = sx
        UserForm1.Label5.Caption = sy
         
        UserForm1.Label6.Caption = UserForm1.Left - sx
        UserForm1.Label7.Caption = UserForm1.Top - sy
       
        UserForm1.Label8.Caption = UserForm1.Left
        UserForm1.Label9.Caption = UserForm1.Top
        
        ny = UserForm1.Top
        nx = UserForm1.Left
        
        Call MOVEs  '・・・・・・これが再描画 
        
             Exit Function
            'WM_MOVE 
            
        Case WM_CONTEXTMENU '右クリック 
        MsgBox "右"
            Exit Function

    End Select

CONTINUE:
    '引当のWindowProcへメッセージを回す。 
    DefaultProc = colDProc(CStr(hwnd))
    WindowProc = CallWindowProc(DefaultProc, hwnd, uMsg, wParam, lParam)

End Function
'■BeginSubClass 
'■機能:サブクラス化を開始する。 
Public Sub BeginSubClass(l As Long)

    Static bAlready As Boolean
    Dim DefaultProc As Long

    If Not bAlready Then
        Set colDProc = New Collection
        bAlready = True
    End If

    'サブクラス化実行 
    DefaultProc = SetWindowLong(l, GWL_WNDPROC, AddressOf WindowProc)

    '元のWindowProcのアドレスを保存 
    colDProc.Add DefaultProc, CStr(l)

End Sub
'■EndSubClass 
'■機能:サブクラス化を終了します。 
Public Sub EndSubClass(l As Long)

    Dim Ret As Long
    Dim DefaultProc As Long

    'WindowProcのアドレスを元に戻す。 
    DefaultProc = colDProc(CStr(l))
    Ret = SetWindowLong(l, GWL_WNDPROC, DefaultProc)
    colDProc.Remove CStr(l)

End Sub

Sub MOVEs()

再描画

End Sub


コードが長くなり、フォームムジュールは次です

投稿者 snowmansnow   (社会人)   投稿日時 2021/3/21 22:56:08
続きのフォームモジュールです
Private Sub CommandButton49_Click()
    
   'ユーザーフォームのハンドルを取得 
    'https://excel-excel.com/tips/vba_69.html 
 Dim hwnd As Long

 If buttonOn = False Then
    hwnd = FindWindow(vbNullString, Me.Caption)
    
    hTargetDC = GetDC(hwnd)

    If hTargetDC = 0 Then
     Cells(1, 3).Value = "失敗しました。"
     Else
     Cells(1, 3).Value = hTargetDC
     End If
      
    Cells(1, 1) = hwnd
    
 'https://tsware.jp/tips/tips_174.htm 
Dim strWindowText As String * 128   'キャプションを受け取る変数 
Dim lngRet As Long

'API関数を呼び出します 
lngRet = GetWindowText(hwnd, strWindowText, Len(strWindowText))

'引数の後続の Null を取り除いて表示します 
Cells(1, 2) = Left$(strWindowText, InStr(strWindowText, vbNullChar) - 1)
        
   Call BeginSubClass(hwnd)
   buttonOn = True
  ' CommandButton1.Enabled = False 
  'http://www.officetanaka.net/excel/vba/tips/tips136.htm 
  
  sy = UserForm1.Top
  sx = UserForm1.Left
  
  
 Else
 End If


End Sub

Private Sub CommandButton50_Click()
 Dim hwnd As Long
    hwnd = FindWindow(vbNullString, Me.Caption)
    Call EndSubClass(hwnd)
    buttonOn = False

End Sub



なぜかWM_PAINTがうまく動きませんでした・・・