Bricacad VB.NET 画面キャプチャサンプル BCapt.dll
■概要
Bricscad .NET 本来の機能で、密かにスナップショットを作成しようと、いろいろやってみたのですが、よく分かりませんでした。
結局、他の外部アプリと同じ手法「スクリーンキャプチャ」を使っています。
表示させている画像は１個だけすが、マウススクロールで切り替わります。
（実際には、コンボボックスをアクティブにして、それが切り替わっています。）
フォームは、モードレス表示です。
どこかで、Bitmapの破棄が必要なのだと思います。
シート番号（図枠ブロックの属性）順にソートされて表示されます。
画像をダブルクリックすると、アクティブな図面が切り替わります。
' system
Imports System.Text
Imports System.Runtime.InteropServices
Imports System.IO
' ODA
Imports Teigha.Runtime
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports Teigha.GraphicsSystem
' Bricsys
Imports Bricscad.ApplicationServices
Imports Bricscad.Runtime
Imports Bricscad.EditorInput
' alias
Imports _AcRx = Teigha.Runtime
Imports _AcAp = Bricscad.ApplicationServices
Imports _AcDb = Teigha.DatabaseServices
Imports _AcGe = Teigha.Geometry
Imports _AcEd = Bricscad.EditorInput
Imports _AcGi = Teigha.GraphicsInterface
Imports _AcClr = Teigha.Colors
Imports _AcWnd = Bricscad.Windows
Imports Bricscad.PlottingServices
Public Class Commands
<CommandMethod("BCapt", CommandFlags.Modal)> _
Public Shared Sub CmdBCapt()
'' ウィンドウのが存在を確認
Dim hWnd As New IntPtr(0)
hWnd = Form1.FindWindow(Nothing, "BCapt")
'' ウィンドウが存在しない
If hWnd.Equals(IntPtr.Zero) Then
Dim frm As Form1 = New Form1
'' モードレス表示
Application.ShowModelessDialog(frm)
'' ここでは破棄しない
''frm.Dispose()
End If
End Sub
End Class
' system
Imports System.Text
Imports System.Runtime.InteropServices
Imports System.IO
Imports System.Drawing
Imports System.Windows.Forms
' ODA
Imports Teigha.Runtime
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports Teigha.GraphicsSystem
' Bricsys
Imports Bricscad.ApplicationServices
Imports Bricscad.Runtime
Imports Bricscad.EditorInput
' com
Imports BricscadDb
Imports BricscadApp
' alias
Imports _AcRx = Teigha.Runtime
Imports _AcAp = Bricscad.ApplicationServices
Imports _AcDb = Teigha.DatabaseServices
Imports _AcGe = Teigha.Geometry
Imports _AcEd = Bricscad.EditorInput
Imports _AcGi = Teigha.GraphicsInterface
Imports _AcClr = Teigha.Colors
Imports _AcWnd = Bricscad.Windows
Imports Bricscad.PlottingServices
Public Class Form1
'' データ保持用構造体
Structure DwgDoc
Dim DwgName As String
Dim DwgPrefix As String
Dim DocIndex As Integer
Dim DimScale As Double
Dim SheetNo As String
Dim PageNo As String
Dim Bmp As Drawing.Bitmap
End Structure
'' 動的配列
Public Shared DwgDocs() As DwgDoc
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
Me.Left = Screen.PrimaryScreen.WorkingArea.Width - Me.Width
Me.Top = Screen.PrimaryScreen.WorkingArea.Height - Me.Height
'If MessageBox.Show("キャプチャを開始しますか？", _
' "BCapt", _
' MessageBoxButtons.YesNo, _
' MessageBoxIcon.Information, _
' MessageBoxDefaultButton.Button1) = DialogResult.Yes Then
' System.Threading.Thread.Sleep(100)
' Button1.PerformClick()
'End If
End Sub
<StructLayout(LayoutKind.Sequential)> _
Private Structure RECT
Public left As Integer
Public top As Integer
Public right As Integer
Public bottom As Integer
End Structure
<DllImport("user32.dll")> _
Private Shared Function GetWindowRect(ByVal hwnd As IntPtr, ByRef lpRect As RECT) As Integer
End Function
Enum GetWindow_Cmd : uint
GW_HWNDFIRST = 0
GW_HWNDLAST = 1
GW_HWNDNEXT = 2
GW_HWNDPREV = 3
GW_OWNER = 4
GW_CHILD = 5
GW_ENABLEDPOPUP = 6
End Enum
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function GetWindow(ByVal hWnd As IntPtr, ByVal uCmd As UInt32) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function FindWindow( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function FindWindowEx(ByVal parentHandle As IntPtr, _
ByVal childAfter As IntPtr, _
ByVal lclassName As String, _
ByVal windowTitle As String) As IntPtr
End Function
<DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function GetWindowText(ByVal hwnd As IntPtr, ByVal lpString As StringBuilder, ByVal cch As Integer) As Integer
End Function
<DllImport("user32.dll", CharSet:=CharSet.Auto)> _
Public Shared Function GetClassName(ByVal hWnd As System.IntPtr, _
ByVal lpClassName As System.Text.StringBuilder, ByVal nMaxCount As Integer) As Integer
End Function
Private Sub Form1_FormClosed(sender As Object, e As FormClosedEventArgs) Handles MyBase.FormClosed
'' ここで破棄
Me.Dispose()
End Sub
'' 図枠ブロックの属性を取得
Public Sub GetAttString(ByRef doc As AcadDocument, ByVal BlkName As String, _
ByVal TagName1 As String, ByVal TagName2 As String, _
ByRef AttString1 As String, ByRef AttString2 As String)
Dim Flag1 As Boolean = False
Dim Flag2 As Boolean = False
Dim mspc As AcadModelSpace = doc.ModelSpace
If mspc.Count > 0 Then
For j As Integer = 0 To mspc.Count - 1
Dim ent As AcadEntity = mspc.Item(j)
If "AcDbBlockReference" = ent.EntityName Then
Dim blkref As AcadBlockReference = ent
If blkref.HasAttributes Then
If BlkName = blkref.Name Then
Dim attr As Object = blkref.GetAttributes
For k As Integer = LBound(attr, 1) To UBound(attr, 1)
Dim att As AcadAttributeReference = attr(k)
If TagName1 = att.TagString Then
AttString1 = att.TextString
Flag1 = True
End If
If TagName2 = att.TagString Then
AttString2 = att.TextString
Flag2 = True
End If
If Flag1 And Flag2 Then Exit For
Next
End If
End If
End If
If Flag1 And Flag2 Then Exit For
Next
End If
End Sub
'' 取得した情報をシート番号順にソート
Public Shared Sub SortDwgDocsSheetNo(pageSort As Boolean)
Dim temp As DwgDoc
Dim s As String
Dim s1 As String
Dim n As Integer = 0
For i As Integer = 0 To UBound(DwgDocs)
If pageSort Then
If n < DwgDocs(i).PageNo.Length Then n = DwgDocs(i).PageNo.Length
End If
Next
If UBound(DwgDocs) > 0 Then
For i As Integer = 0 To UBound(DwgDocs) - 1
If pageSort Then
s = Microsoft.VisualBasic.Right("0000" + DwgDocs(i).PageNo, n)
Else
s = DwgDocs(i).SheetNo
End If
For j As Integer = i + 1 To UBound(DwgDocs)
If pageSort Then
s1 = Microsoft.VisualBasic.Right("0000" + DwgDocs(j).PageNo, n)
Else
s1 = DwgDocs(j).SheetNo
End If
If s > s1 Then
temp = DwgDocs(i) : DwgDocs(i) = DwgDocs(j) : DwgDocs(j) = temp
s = s1
End If
Next
Next
End If
End Sub
'' キャプチャボタン
Private Sub Button1_Click_1(sender As Object, e As EventArgs) Handles Button1.Click
Const bmpW As Integer = 240
Const bmpH As Integer = 170
ComboBox1.Items.Clear()
Dim app As IAcadApplication = _AcAp.Application.AcadApplication
Dim appDocs As IAcadDocuments = app.Documents
Dim appDoc As IAcadDocument
ReDim DwgDocs(appDocs.Count - 1)
Dim stIndex As Integer = -1
For i As Integer = 0 To appDocs.Count - 1
If appDocs.Item(i).Active Then
stIndex = i
Exit For
End If
Next
For i As Integer = 0 To appDocs.Count - 1
appDoc = appDocs.Item(i)
appDoc.Activate()
With DwgDocs(i)
GetAttString(appDoc, "TITLE", "ZSHEET", "ZITEM9", .SheetNo, .PageNo)
.DocIndex = i
.DwgPrefix = appDoc.GetVariable("DWGPREFIX")
.DwgName = appDoc.GetVariable("DWGNAME")
End With
Dim lmax(1) As Double
lmax = appDoc.GetVariable("LIMMAX")
Dim lmin(1) As Double
lmin = appDoc.GetVariable("LIMMIN")
Dim h As Integer = FindWindowEx(app.ActiveDocument.HWND, IntPtr.Zero, "AfxFrameOrView100u", "")
If h <> 0 Then
Dim rec As RECT
GetWindowRect(h, rec)
app.ZoomWindow(lmin, lmax)
Dim recWidth As Integer = rec.right - rec.left
Dim recHeight As Integer = rec.bottom - rec.top
Dim scale As Double
If bmpH / bmpW < recHeight / recWidth Then
scale = bmpW / recWidth
Else
scale = bmpH / recHeight
End If
Dim gridMode As Integer = appDoc.GetVariable("GRIDMODE")
Dim ucsICon As Integer = appDoc.GetVariable("UCSICON")
If gridMode > 0 Then appDoc.SetVariable("GRIDMODE", 0)
If ucsICon > 0 Then appDoc.SetVariable("UCSICON", 0)
app.ZoomScaled(scale, AcZoomScaleType.acZoomScaledRelative)
''Bitmapの生成
Dim bmp As New Bitmap(bmpW, bmpH)
''Graphicsの作成
Dim gr As Graphics = Graphics.FromImage(bmp)
'' グラフィック画面の中心キャプチャする
gr.CopyFromScreen(
New Point(rec.left + Int((recWidth - bmpW) / 2), rec.top + Int((recHeight - bmpH) / 2)),
New Point(0, 0), bmp.Size)
'' 破棄
gr.Dispose()
DwgDocs(i).Bmp = New Bitmap(bmp)
app.ZoomPrevious()
If gridMode > 0 Then appDoc.SetVariable("GRIDMODE", gridMode)
If ucsICon > 0 Then appDoc.SetVariable("UCSICON", ucsICon)
End If
Next
appDoc = appDocs.Item(stIndex)
appDoc.Activate()
appDoc = Nothing
appDocs = Nothing
app = Nothing
'' ソート
SortDwgDocsSheetNo(False)
'' コンボボックスにファイル名を追加
For i As Integer = 0 To UBound(DwgDocs)
ComboBox1.Items.Add(DwgDocs(i).SheetNo + ":" + DwgDocs(i).DwgName)
Next
'' コンボボックスのインデックスを最初の図面にする
For i As Integer = 0 To UBound(DwgDocs)
If DwgDocs(i).DocIndex = stIndex Then
ComboBox1.SelectedIndex = i
Exit For
End If
Next
'System.Threading.Thread.Sleep(100)
'Me.Focus()
'' フォーカスをコンボボックスに
ComboBox1.Focus()
End Sub
'' ビットマップとファイル名を更新
Private Sub ComboBox1_SelectedIndexChanged(sender As Object, e As EventArgs) Handles ComboBox1.SelectedIndexChanged
Dim idx As Integer = ComboBox1.SelectedIndex
If idx >= 0 Then
PictureBox1.Image = DwgDocs(idx).Bmp
Label1.Text = DwgDocs(idx).DwgName
End If
End Sub
Private Sub PictureBox1_Click(sender As Object, e As EventArgs) Handles PictureBox1.Click
End Sub
'' アクティブなドキュメントを切り替え
Private Sub PictureBox1_MouseDoubleClick(sender As Object, e As MouseEventArgs) Handles PictureBox1.MouseDoubleClick
Dim ret As Boolean = False
Dim idx As Integer = ComboBox1.SelectedIndex
If idx >= 0 Then
Dim app As IAcadApplication = _AcAp.Application.AcadApplication
Dim appDocs As IAcadDocuments = app.Documents
Dim appDoc As IAcadDocument
For i As Integer = 0 To appDocs.Count - 1
appDoc = appDocs.Item(i)
If (DwgDocs(idx).DwgPrefix = appDoc.GetVariable("DWGPREFIX")) And _
(DwgDocs(idx).DwgName = appDoc.GetVariable("DWGNAME")) Then
appDoc.Activate()
ret = True
Exit For
End If
Next
'' 取得時と同じファイル名が無い
If Not ret Then
MsgBox("DwgPrefix : " + DwgDocs(idx).DwgPrefix + vbCrLf + _
"DwgNme : " + DwgDocs(idx).DwgName + vbCrLf + "が、見つかりません．", MsgBoxStyle.OkOnly, "BCapt")
End If
End If
End Sub
End Class