□NTEDN : 選択順で TEXT を一括で編集します。TEXT の追加はできません。
空白行の TEXT は削除されます。
編集の行数が取得した TEXT 数を超えると、背景色が変わります。
取得した TEXT 数だけが、更新の対象になり、以降は無視されます。
□NTEDY : 座標順にソート後 TEXT を一括で編集します。
取得した TEXT が横方向に広がっているときは、X 座標の昇順、
縦方向に広がっているときは、Ｙ座標の降順でソートします。
取得した TEXT の一番下側または、一番右側とその直前の TEXT の座標の
X 座標または Y 座標の差で、次の TEXT を作成します。
'' Class1 ----------------------------------------
'' 2024/12/12
Imports Teigha.Runtime
Imports HostMgd.ApplicationServices
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports HostMgd.EditorInput
''
Imports System.Drawing
'' com
'Imports nanoCAD
'Imports OdaX
' alias
Imports _AcRx = Teigha.Runtime
Imports _AcAp = HostMgd.ApplicationServices
Imports _AcDb = Teigha.DatabaseServices
Imports _AcGe = Teigha.Geometry
Imports _AcEd = HostMgd.EditorInput
Imports _AcGi = Teigha.GraphicsInterface
Imports _AcClr = Teigha.Colors
Imports _AcWnd = HostMgd.Windows
Public Class Class1
'Declare Function FindWindow Lib "user32" Alias _
' "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As Integer) As Integer
Public Shared Function GetPolar(ByVal pPt As Point3d, ByVal dAng As Double, ByVal dDist As Double) As Point3d
Return New Point3d(pPt.X + dDist * Math.Cos(dAng), pPt.Y + dDist * Math.Sin(dAng), 0.0)
End Function
Public Shared Function GetPolar(ByVal pPt As Point2d, ByVal dAng As Double, ByVal dDist As Double) As Point2d
Return New Point2d(pPt.X + dDist * Math.Cos(dAng), pPt.Y + dDist * Math.Sin(dAng))
End Function
Public Shared Function GetAngle(p1 As Point2d, p2 As Point2d) As Double
Dim fuzz = 0.0000001
Dim dx, dy As Double
dx = p2.X - p1.X
dy = p2.Y - p1.Y
If Math.Abs(dx) >= fuzz And Math.Abs(dy) >= fuzz Then
Return Math.Atan2(dy, dx)
ElseIf Math.Abs(dx) < fuzz Then
If p2.Y > p1.Y Then
Return Math.PI * 0.5
Else
Return Math.PI * 1.5
End If
ElseIf Math.Abs(dy) < fuzz Then
If p2.X > p1.X Then
Return 0.0
Else
Return Math.PI
End If
End If
End Function
Public Shared Function GetAngle(p1 As Point3d, p2 As Point3d) As Double
Return GetAngle(New Point2d(p1.X, p1.Y), New Point2d(p2.X, p2.Y))
End Function
Public Shared Function GetDistance(p1 As Point3d, p2 As Point3d) As Double
Return Math.Sqrt((p2.X - p1.X) * (p2.X - p1.X) + (p2.Y - p1.Y) * (p2.Y - p1.Y))
End Function
Public Shared Function GetDistance(p1 As Point2d, p2 As Point2d) As Double
Return Math.Sqrt((p2.X - p1.X) * (p2.X - p1.X) + (p2.Y - p1.Y) * (p2.Y - p1.Y))
End Function
Public Shared Sub BulgeToArc(p1 As Point2d, p2 As Point2d, bulge As Double, ByRef p0 As Point2d,
ByRef rad As Double, ByRef st As Double, ByRef ed As Double)
Dim naikaku, d, hankei, kakudo1 As Double
' 膨らみから、ARCの中心の内角を求める
naikaku = Math.Atan(bulge) * 4.0
' ARCの始点-終点間の距離の１/２を求める
d = GetDistance(p1, p2) / 2.0
' 半径を求める
hankei = d / Math.Sin(naikaku / 2.0)
rad = Math.Abs(hankei)
' 中心座標を求める
kakudo1 = Math.PI / 2.0 - naikaku / 2.0
p0 = GetPolar(p1, kakudo1 + GetAngle(p1, p2), hankei)
' 膨らみの値により始点終点を入れ替える
If bulge < 0.0 Then
st = GetAngle(p0, p2)
ed = GetAngle(p0, p1)
Else
st = GetAngle(p0, p1)
ed = GetAngle(p0, p2)
End If
End Sub
'' 四捨五入
Public Shared Function RoundOff(d As Double, keta As Integer) As Double
Dim x As Double = 10 ^ keta
If d > 0 Then
Return Math.Floor(d * x + 0.5) / x
Else
Return Math.Floor(d * x + 0.5) / x
End If
End Function
'' データ保持用構造体
Structure TxtRecord
Dim index As Integer
Dim objId As ObjectId
Dim txtString As String
Dim txtPos As Point3d
End Structure
Public Shared TxtAry() As TxtRecord
Structure BlkRecord
Dim objId As ObjectId
Dim blkName As String
End Structure
Public Shared BlkAry() As BlkRecord
''ソート sortSw : 0=index 昇順, 1=X 昇順, 2=Y 降順
Public Shared Sub SortTxtAry(sortSw As Integer)
If TxtAry.Length > 1 Then
Dim temp As TxtRecord
For i = 0 To TxtAry.Length - 2
For j = i + 1 To TxtAry.Length - 1
If (sortSw = 0 And TxtAry(i).index > TxtAry(j).index) Or
(sortSw = 1 And TxtAry(i).txtPos.X > TxtAry(j).txtPos.X) Or
(sortSw = 2 And TxtAry(i).txtPos.Y < TxtAry(j).txtPos.Y) Then
temp = TxtAry(i)
TxtAry(i) = TxtAry(j)
TxtAry(j) = temp
End If
Next
Next
End If
End Sub
'' 最小、最大座標
Public Shared Sub RectTxtAry(ByRef minx As Double, ByRef miny As Double, ByRef maxx As Double, ByRef maxy As Double)
If TxtAry.Length > 0 Then
For i = 0 To TxtAry.Length - 1
With TxtAry(i).txtPos
If i = 0 Then
minx = .X
miny = .Y
maxx = .X
maxy = .Y
Else
minx = Math.Min(minx, .X)
miny = Math.Min(miny, .Y)
maxx = Math.Max(maxx, .X)
maxy = Math.Max(maxy, .Y)
End If
End With
Next
End If
End Sub
Public Shared Sub DispTxtAry(ByRef edform As Form1)
With edform
.TextBox1.Text = ""
For i = 0 To TxtAry.Length - 1
.TextBox1.Text += TxtAry(i).txtString
If i < TxtAry.Length - 1 Then
.TextBox1.Text += vbCrLf
End If
Next
.Label1.Text = "TEXT 数 = " & TxtAry.Length.ToString
.txtarycnt = TxtAry.Length
End With
End Sub
<CommandMethod("ntedn", CommandFlags.Modal)>
Public Shared Sub NtextEditN()
NtextEdit(False)
End Sub
<CommandMethod("ntedy", CommandFlags.Modal)>
Public Shared Sub NtextEditY()
NtextEdit(True)
End Sub
Public Shared Sub NtextEdit(sortFlag As Boolean)
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
'' 選択フィルター
Dim TypValAr(0) As TypedValue
TypValAr.SetValue(New TypedValue(DxfCode.Start, "TEXT"), 0)
Dim SelFtr As SelectionFilter = New SelectionFilter(TypValAr)
If sortFlag Then
ed.WriteMessage(vbLf & "座標順で一括編集する TEXT をガバっと選択して下さい.")
Else
ed.WriteMessage(vbLf & "選択順で一括編集する TEXT を順に選択して下さい.")
End If
'' 選択
Dim res As PromptSelectionResult = ed.GetSelection(SelFtr)
If (res.Status = PromptStatus.OK) Then
Dim SSet As _AcEd.SelectionSet = res.Value
If SSet.Count > 0 Then
Dim edForm As Form1 = New Form1()
If sortFlag Then
edForm.Text = "NTED-Y : TEXT 一括編集(座標順=追加可能）"
Else
edForm.Text = "NTED-N : TEXT 一括編集(選択順=追加不可）"
End If
'' データ格納
ReDim TxtAry(SSet.Count - 1)
Dim idx As Integer = 0
For Each SSObj As SelectedObject In SSet
If Not IsDBNull(SSObj) Then
Dim ssTxt As DBText = tr.GetObject(SSObj.ObjectId, OpenMode.ForRead)
If Not IsDBNull(ssTxt) Then
With TxtAry(idx)
.index = idx
.txtString = ssTxt.TextString
.objId = ssTxt.ObjectId
If ssTxt.Justify = AttachmentPoint.BaseLeft Then
.txtPos = ssTxt.Position
Else
.txtPos = ssTxt.AlignmentPoint
End If
End With
idx += 1
End If
End If
Next
If TxtAry.Length > 0 Then
Dim sw As Integer = 0
'' TEXT の並び方向
If TxtAry.Length > 1 Then
Dim minx, miny As Double
Dim maxx, maxy As Double
RectTxtAry(minx, miny, maxx, maxy)
Dim tateFlag As Boolean = (maxy - miny) > (maxx - minx) ''縦並び
If sortFlag Then
If tateFlag Then
sw = 2
Else
sw = 1
End If
End If
edForm.sortSw = sw '' TextBox の背景色の切り換え用
''ソート
If sw > 0 Then
SortTxtAry（sw)
End If
End If
'' Form に表示
DispTxtAry(edForm)
If _AcAp.Application.ShowModalDialog(edForm) = vbOK Then
Dim arr() As String = Split(edForm.TextBox1.Text, vbCrLf)
'' 修正
For i = 0 To arr.Length - 1
If i < TxtAry.Length Then
Dim objTxt As DBText = tr.GetObject(TxtAry(i).objId, OpenMode.ForWrite)
If arr(i) <> "" Then
If objTxt.TextString <> arr(i) Then objTxt.TextString = arr(i)
Else
objTxt.Erase() ''空白文字を削除
End If
Else
'' あとで追加
End If
Next
''削除 2024/12/08 追加
If TxtAry.Length > arr.Length Then
For i = arr.Length To TxtAry.Length - 1
Dim objTxt As DBText = tr.GetObject(TxtAry(i).objId, OpenMode.ForWrite)
objTxt.Erase()
Next
End If
''追加
Dim len As Integer = TxtAry.Length
If sw > 0 And len > 1 And arr.Length > len Then
Dim dx As Double = 0
Dim dy As Double = 0
If sw = 2 Then ''縦並び
dy = TxtAry(len - 1).txtPos.Y - TxtAry(len - 2).txtPos.Y
Else
dx = TxtAry(len - 1).txtPos.X - TxtAry(len - 2).txtPos.X
End If
Dim Bt As BlockTable = TryCast(tr.GetObject(db.BlockTableId, OpenMode.ForWrite), BlockTable)
Dim Btr As BlockTableRecord = TryCast(tr.GetObject(Bt("*Model_Space"), OpenMode.ForWrite), BlockTableRecord)
'' 最後の TEXT
Dim orgTxt As DBText = tr.GetObject(TxtAry(len - 1).objId, OpenMode.ForWrite)
Dim n As Integer = 1
'' 追加
For i = len To arr.Length - 1
Dim clonedTxt As DBText = TryCast(orgTxt.Clone(), DBText)
clonedTxt.TextString = arr(i)
If clonedTxt.Justify = AttachmentPoint.BaseLeft Then
clonedTxt.Position = New Point3d(clonedTxt.Position.X + dx * n, clonedTxt.Position.Y + dy * n, 0)
Else
clonedTxt.AlignmentPoint = New Point3d(clonedTxt.AlignmentPoint.X + dx * n, clonedTxt.AlignmentPoint.Y + dy * n, 0)
End If
Btr.AppendEntity(clonedTxt)
tr.AddNewlyCreatedDBObject(clonedTxt, True)
n += 1
Next
Bt.Dispose()
Btr.Dispose()
End If
'' 変更を反映
tr.Commit()
End If
'' フォーム破棄
edForm.Dispose()
End If
End If
End If
Catch ex As System.Exception
_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
End Sub
Public Shared Sub SortBlkAry()
If BlkAry.Length > 1 Then
Dim temp As BlkRecord
For i = 0 To BlkAry.Length - 2
For j = i + 1 To BlkAry.Length - 1
If BlkAry(i).blkName.ToUpper() > BlkAry(j).blkName.ToUpper() Then
temp = BlkAry(i)
BlkAry(i) = BlkAry(j)
BlkAry(j) = temp
End If
Next
Next
End If
End Sub
<CommandMethod("blkin", CommandFlags.Modal)>
Public Shared Sub BlkIn()
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
Dim tbl As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead, False)
Dim enu1 As IEnumerator = tbl.GetEnumerator()
Dim objId As ObjectId
Dim cnt As Integer = 0
While enu1.MoveNext()
objId = enu1.Current
Dim rec As BlockTableRecord = tr.GetObject(objId, OpenMode.ForRead, False)
Dim c As String = Left(rec.Name, 1)
If c <> "*" And c <> "_" And c <> "$" Then
'' ブロック名の列挙
''ed.WriteMessage(vbLf & rec.Name)
cnt += 1
ReDim Preserve BlkAry(cnt - 1)
With BlkAry(cnt - 1)
.objId = objId
.blkName = rec.Name
End With
End If
End While
If cnt > 0 Then
SortBlkAry()
Dim blkForm As Form2 = New Form2()
Dim i As Integer
For i = 0 To BlkAry.Length - 1
blkForm.ListBox1.Items.Add(BlkAry(i).blkName)
Next
If _AcAp.Application.ShowModalDialog(blkForm) = vbOK Then
Dim blkName As String = blkForm.TextBox1.Text
Dim index As Integer = blkForm.ListBox1.FindString(blkName)
Dim blkRecId As ObjectId
If BlkAry.Length > index Then
blkRecId = BlkAry(index).objId
If blkRecId <> ObjectId.Null Then
Using blkref As New BlockReference(New Point3d(0, 0, 0), blkRecId)
Dim curSpaceBlkTblRec As BlockTableRecord
curSpaceBlkTblRec = tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite)
curSpaceBlkTblRec.AppendEntity(blkref)
tr.AddNewlyCreatedDBObject(blkref, True)
'' 2024/12/11c
Dim blkdef As BlockTableRecord = tr.GetObject(tbl(blkName), OpenMode.ForWrite)
If blkdef.HasAttributeDefinitions Then
For Each oid As ObjectId In blkdef
Dim dbObj As DBObject = tr.GetObject(oid, OpenMode.ForRead)
If TypeOf (dbObj) Is AttributeDefinition Then
Dim acAtt As AttributeDefinition = dbObj
If Not acAtt.Constant Then
Using attref As AttributeReference = New AttributeReference()
attref.SetAttributeFromBlock(acAtt, blkref.BlockTransform)
attref.Position = acAtt.Position.TransformBy(blkref.BlockTransform)
attref.TextString = acAtt.TextString
blkref.AttributeCollection.AppendAttribute(attref)
tr.AddNewlyCreatedDBObject(attref, True)
End Using
End If
End If
Next
End If
tr.Commit()
doc.SendStringToExecute("copybase L " & vbCr & "0,0 ", True, False, False)
doc.SendStringToExecute("erase L " & vbCr, True, False, False)
doc.SendStringToExecute("pasteclip ", True, False, False)
'Dim ncadApp As Object = GetObject("", "nanoCAD.Application.5.0")
'Dim ncadDoc As Object = ncadApp.ActiveDocument
'ncadDoc.SendCommand("copybase L " & vbCr & "0,0 ")
'ncadDoc.SendCommand("erase L " & vbCr)
'ncadDoc.SendCommand("pasteclip ")
End Using
End If
End If
End If
blkForm.Dispose()
End If
Catch ex As Exception
_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
End Sub
End Class
'' Form1 -------------------------------------------------------
'' nted 用
Imports Teigha.Runtime
Imports HostMgd.ApplicationServices
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports HostMgd.EditorInput
Public Class Form1
Public txtarycnt As Integer = 0
Public sortSw As Integer = 0
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
End Sub
Private Sub Button2_Click(sender As Object, e As EventArgs) Handles Button2.Click
Me.Hide()
End Sub
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
'フォームのLoadイベントハンドラ
''Me.AutoSize = True
''Me.AutoSizeMode = System.Windows.Forms.AutoSizeMode.GrowAndShrink
Me.AutoSize = False
Me.AutoSizeMode = System.Windows.Forms.AutoSizeMode.GrowOnly
'フォームの最大サイズを画面サイズにする
Me.MaximumSize = System.Windows.Forms.Screen.GetBounds(Me).Size
'Me.Width = System.Windows.Forms.Screen.GetBounds(Me).Width \ 2
'Me.Height = System.Windows.Forms.Screen.GetBounds(Me).Height \ 2
End Sub
Private Sub TextBox1_TextChanged(sender As Object, e As EventArgs) Handles TextBox1.TextChanged
Dim len As Integer = TextBox1.Lines().Length
Label2.Text = "現在の行数 = " & len.ToString
'' TextBox の背景色を変更
With TextBox1
If sortSw = 0 And txtarycnt > 0 And len > txtarycnt Then
If .BackColor <> Drawing.Color.FromArgb(255, 255, 191) Then .BackColor = Drawing.Color.FromArgb(255, 255, 191)
ElseIf sortSw > 0 And txtarycnt > 0 And len > txtarycnt Then
If .BackColor <> Drawing.Color.FromArgb(191, 255, 255) Then .BackColor = Drawing.Color.FromArgb(191, 255, 255)
Else
If .BackColor <> Drawing.Color.White Then .BackColor = Drawing.Color.White
End If
End With
End Sub
Private Sub TextBox1_KeyDown(sender As Object, e As Windows.Forms.KeyEventArgs) Handles TextBox1.KeyDown
If (e.Modifiers And Windows.Forms.Keys.Shift) = Windows.Forms.Keys.Shift Then
If e.KeyCode = 13 Then
'Me.Text = "Shift+Enter"
'Button1_Click(Button1, EventArgs.Empty)
End If
ElseIf e.KeyCode = 27 Then
Button2_Click(Button2, EventArgs.Empty)
End If
End Sub
End Class
'' Form2 -------------------------------------------------------
'' blkin 用
'' 2024/12/11c
Imports Teigha.Runtime
Imports HostMgd.ApplicationServices
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports HostMgd.EditorInput
'' for Form2
Imports System.Drawing
' alias
Imports _AcRx = Teigha.Runtime
Imports _AcAp = HostMgd.ApplicationServices
Imports _AcDb = Teigha.DatabaseServices
Imports _AcGe = Teigha.Geometry
Imports _AcEd = HostMgd.EditorInput
Imports _AcGi = Teigha.GraphicsInterface
Imports _AcClr = Teigha.Colors
Imports _AcWnd = HostMgd.Windows
Public Class Form2
Sub DrawLine(bmpW As Integer, bmpH As Integer, cenx As Double, ceny As Double, scale As Double, p1 As Point3d, p2 As Point3d, ByRef g As Graphics, apen As Pen)
Dim x1, y1, x2, y2 As Integer
x1 = Class1.RoundOff((p1.X - cenx) * scale + bmpW / 2, 0)
y1 = bmpH - Class1.RoundOff(((p1.Y - ceny) * scale + bmpH / 2), 0)
x2 = Class1.RoundOff((p2.X - cenx) * scale + bmpW / 2, 0)
y2 = bmpH - Class1.RoundOff(((p2.Y - ceny) * scale + bmpH / 2), 0)
g.DrawLine(apen, x1, y1, x2, y2)
End Sub
Sub DrawCircle(bmpW As Integer, bmpH As Integer, cenx As Double, ceny As Double, scale As Double, p0 As Point3d, rad As Double, ByRef g As Graphics, apen As Pen)
Dim x, y, d As Integer
x = Class1.RoundOff((p0.X - cenx) * scale + bmpW / 2, 0)
y = bmpH - Class1.RoundOff(((p0.Y - ceny) * scale + bmpH / 2), 0)
x = Class1.RoundOff(x - rad * scale, 0)
y = Class1.RoundOff(y - rad * scale, 0)
d = Class1.RoundOff(rad * scale * 2, 0)
If d > 0 Then '' 2024/12/11a
g.DrawEllipse(apen, x, y, d, d)
End If
End Sub
Sub DrawRect(bmpW As Integer, bmpH As Integer, cenx As Double, ceny As Double, scale As Double, p1 As Point3d, p2 As Point3d, ByRef g As Graphics, apen As Pen)
Dim x1, y1, x2, y2 As Integer
x1 = Class1.RoundOff((p1.X - cenx) * scale + bmpW / 2, 0)
y1 = bmpH - Class1.RoundOff(((p1.Y - ceny) * scale + bmpH / 2), 0)
x2 = Class1.RoundOff((p2.X - cenx) * scale + bmpW / 2, 0)
y2 = bmpH - Class1.RoundOff(((p2.Y - ceny) * scale + bmpH / 2), 0)
g.DrawRectangle(apen, x1, y2, x2 - x1, y1 - y2)
End Sub
Sub DrawArc(bmpW As Integer, bmpH As Integer, cenx As Double, ceny As Double, scale As Double, p0 As Point3d, rad As Double, stang As Double, edang As Double, ByRef g As Graphics, apen As Pen)
Dim x, y, d As Integer
x = Class1.RoundOff((p0.X - cenx) * scale + bmpW / 2, 0)
y = bmpH - Class1.RoundOff(((p0.Y - ceny) * scale + bmpH / 2), 0)
x = Class1.RoundOff(x - rad * scale, 0)
y = Class1.RoundOff(y - rad * scale, 0)
d = Class1.RoundOff(rad * scale * 2, 0)
Dim deg1, deg2 As Integer
deg1 = Class1.RoundOff(stang / Math.PI * 180.0, 0)
deg2 = Class1.RoundOff(edang / Math.PI * 180.0, 0)
If deg2 < deg1 Then
deg2 += 360
End If
Dim degsa As Integer = Math.Abs(deg2 - deg1)
If degsa > 0 And d > 0 Then ''2024/12/11a
g.DrawArc(apen, x, y, d, d, -deg1, -degsa)
End If
End Sub
Public Sub DrawBlockImage(ByVal blkObjId As ObjectId)
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using tr As Transaction = db.TransactionManager.StartTransaction
Dim dxfName As String = ""
Try
Dim rec As BlockTableRecord = tr.GetObject(blkObjId, OpenMode.ForRead)
'' ブロック名の列挙
''ed.WriteMessage(vbLf & rec.Name)
'' 描画範囲
Dim minx, miny, maxx, maxy As Double
'' 描画対象の図形を保持
Dim objids As ObjectIdCollection = New ObjectIdCollection
Dim ent As Entity
Dim cnt As Integer = 0
Dim entcnt As Integer = 0
Dim txtcnt As Integer = 0
Dim mtxtcnt As Integer = 0
Dim attcnt As Integer = 0
Dim blkcnt As Integer = 0
For Each id As ObjectId In rec
entcnt += 1
ent = tr.GetObject(id, OpenMode.ForRead)
dxfName = ent.GetRXClass().DxfName
If dxfName = "LINE" Or dxfName = "ARC" Or dxfName = "CIRCLE" Or dxfName = "LWPOLYLINE" Or dxfName = "INSERT" Then
objids.Add(id)
Dim ext As Extents3d = ent.Bounds
If cnt = 0 Then
minx = ext.MinPoint.X
miny = ext.MinPoint.Y
maxx = ext.MaxPoint.X
maxy = ext.MaxPoint.Y
Else
minx = Math.Min(minx, ext.MinPoint.X)
miny = Math.Min(miny, ext.MinPoint.Y)
maxx = Math.Max(maxx, ext.MaxPoint.X)
maxy = Math.Max(maxy, ext.MaxPoint.Y)
End If
cnt += 1
ElseIf dxfName = "TEXT" Then
objids.Add(id)
txtcnt += 1
ElseIf dxfName = "MTEXT" Then
objids.Add(id)
mtxtcnt += 1
ElseIf dxfName = "ATTDEF" Then
attcnt += 1
Else
''ed.WriteMessage(vbLf & dxfName)
End If
If dxfName = "INSERT" Then
blkcnt += 1
End If
Next
Label2.Text = ""
Label3.Text = ""
Label4.Text = "TEXT = " & txtcnt.ToString
Label5.Text = "MTEXT = " & mtxtcnt.ToString
Label6.Text = "ATTDEF = " & attcnt.ToString
If attcnt > 0 Then
Label6.ForeColor = Color.Red
Else
Label6.ForeColor = Color.Black
End If
Label7.Text = "INSERT = " & blkcnt.ToString
Label1.Text = "図形数 = " & entcnt.ToString
''usesInsertCmd = attcnt > 0 '' 2024/12/11a
Dim bmpW As Integer = PictureBox1.Width
Dim bmpH As Integer = PictureBox1.Height
Dim img As New Bitmap(bmpW, bmpH)
Dim g As Graphics = Graphics.FromImage(img)
g.FillRectangle(Brushes.Black, g.VisibleClipBounds)
Try
If cnt > 0 Then
'' 描画範囲
Label3.Text = (maxx - minx).ToString("F1") & " x " & (maxy - miny).ToString("F1")
'' 描画
Dim dx As Double = maxx - minx
Dim dy As Double = maxy - miny
Dim cenx As Double = (maxx + minx) / 2
Dim ceny As Double = (maxy + miny) / 2
Dim scale As Double
If dx > dy Then
scale = bmpW / dx
Else
scale = bmpH / dy
End If
scale *= 0.85
For Each objid As ObjectId In objids
ent = tr.GetObject(objid, OpenMode.ForRead)
dxfName = ent.GetRXClass().DxfName
If dxfName = "LINE" Then
Dim ln As Line = TryCast(ent, Line)
DrawLine(bmpW, bmpH, cenx, ceny, scale, ln.StartPoint, ln.EndPoint, g, Pens.White)
ElseIf dxfName = "CIRCLE" Then
Dim cir As Circle = TryCast(ent, Circle)
DrawCircle(bmpW, bmpH, cenx, ceny, scale, cir.Center, cir.Radius, g, Pens.White)
ElseIf dxfName = "ARC" Then
Dim arcEnt As Arc = TryCast(ent, Arc)
DrawArc(bmpW, bmpH, cenx, ceny, scale, arcEnt.Center, arcEnt.Radius, arcEnt.StartAngle, arcEnt.EndAngle, g, Pens.White)
ElseIf dxfName = "LWPOLYLINE" Then
Dim pl As Polyline = TryCast(ent, Polyline)
Dim pt1, pt2, pt0 As Point2d
Dim bul1, bul2, rad, stang, edang As Double
For i As Integer = 0 To pl.NumberOfVertices - 2
pt1 = pl.GetPoint2dAt(i)
pt2 = pl.GetPoint2dAt(i + 1)
bul1 = pl.GetBulgeAt(i)
bul2 = pl.GetBulgeAt(i + 1)
If Math.Abs(bul1) <= 0.000001 Then
DrawLine(bmpW, bmpH, cenx, ceny, scale, New Point3d(pt1.X, pt1.Y, 0), New Point3d(pt2.X, pt2.Y, 0), g, Pens.White)
Else
Class1.BulgeToArc(pt1, pt2, bul1, pt0, rad, stang, edang)
DrawArc(bmpW, bmpH, cenx, ceny, scale, New Point3d(pt0.X, pt0.Y, 0), rad, stang, edang, g, Pens.White)
End If
Next
If pl.Closed Then
pt1 = pt2
pt2 = pl.GetPoint2dAt(0)
bul1 = bul2
If Math.Abs(bul1) <= 0.000001 Then
DrawLine(bmpW, bmpH, cenx, ceny, scale, New Point3d(pt1.X, pt1.Y, 0), New Point3d(pt2.X, pt2.Y, 0), g, Pens.White)
Else
Class1.BulgeToArc(pt1, pt2, bul1, pt0, rad, stang, edang)
DrawArc(bmpW, bmpH, cenx, ceny, scale, New Point3d(pt0.X, pt0.Y, 0), rad, stang, edang, g, Pens.White)
End If
End If
ElseIf dxfName = "INSERT" Then
Dim ext As Extents3d = ent.Bounds
DrawRect(bmpW, bmpH, cenx, ceny, scale, ext.MinPoint, ext.MaxPoint, g, Pens.Red)
DrawLine(bmpW, bmpH, cenx, ceny, scale, ext.MinPoint, ext.MaxPoint, g, Pens.Red)
DrawLine(bmpW, bmpH, cenx, ceny, scale,
New Point3d(ext.MinPoint.X, ext.MaxPoint.Y, 0),
New Point3d(ext.MaxPoint.X, ext.MinPoint.Y, 0), g, Pens.Red)
ElseIf dxfName = "TEXT" Or dxfName = "MTEXT" Then
Dim ext As Extents3d = ent.Bounds
DrawRect(bmpW, bmpH, cenx, ceny, scale, ext.MinPoint, ext.MaxPoint, g, Pens.Lime)
End If
Next
End If
''PictureBox1.Image = img
Finally
g.Dispose()
PictureBox1.Image = img
End Try
Catch ex As System.Exception
Label2.Text = ex.Message & " " & dxfName
PictureBox1.Image = Nothing
Label4.Text = "TEXT = "
Label5.Text = "MTEXT = "
Label6.Text = "ATTDEF = "
Label7.Text = "INSERT = "
Label1.Text = "図形数 = "
''_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
End Sub
Private Sub ListBox1_SelectedIndexChanged(sender As Object, e As EventArgs) Handles ListBox1.SelectedIndexChanged
Dim curItem As String = ListBox1.SelectedItem.ToString
TextBox1.Text = curItem
Dim index As Integer = ListBox1.FindString(curItem)
If Class1.BlkAry.Length > index Then
Dim objId As ObjectId = Class1.BlkAry(index).objId
DrawBlockImage(objId)
End If
End Sub
Private Sub Form2_Shown(sender As Object, e As EventArgs) Handles MyBase.Shown
With ListBox1
If .Items.Count > 0 Then
.SelectedIndex = 0
End If
End With
End Sub
End Class
