今回は、前回の　[12]　Excelとの連携②-5　指定画層にOffset　で作成したWorkBookの改訂版で、ハッチングを検討しました。
合わせて、作図終了時の、Excel画面の最前面表示についても検討しました。

前回のWorkBookの使いまわしで、名前を変更して作成しました。
ThisWorkBookのWorkbook_Open()のコードは同じです。
Module2は、解放して削除し、Module1のコードを変更しています。

WorkSheetは、Sheet2を削除し、Sheet1を以下にしました。
５行目のパターン名は、E列に入力したパターン名のデーターから入力規制でリスト選択にしました。

Rectangとcirclehaは図形選択でハッチング、Plineは図形内選択でハッチングした例です。

Module1のVBAコード

Option Explicit

''Sleep関数
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
''クラス名またはキャプションタイトルからウィンドウハンドルを取得
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
''フォアグラウンドウィンドウのハンドルを取得。
Declare PtrSafe Function GetForegroundWindow Lib "user32" () As Long
''指定されたウィンドウのハンドルからキャプションタイトルを取得。
Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
''指定されたウィンドウをZオーダーのトップ位置に移動。
Declare PtrSafe Function SetForegroundWindow Lib "user32" (ByVal hwnd As LongPtr) As Long

Sub AddHatch()

''NUMLOCK用
Dim WshShell
Set WshShell = CreateObject("WScript.Shell")
''BricsCADオブジェクト変数
Dim BcadApp As BricscadApp.AcadApplication
Dim BcadDoc As BricscadApp.AcadDocument
''現在開いているBricsCADを取得する
Set BcadApp = GetObject(, "BricscadApp.AcadApplication")
BcadApp.Visible = True
Set BcadDoc = BcadApp.ActiveDocument
''現在の画層名を取得
Dim CurLyr As String
CurLyr = BcadDoc.ActiveLayer.Name
''ﾊｯﾁﾝｸﾞ用画層名を取得
Dim SelLyr As String
SelLyr = ActiveSheet.ComboBox1.Value

''作図方法
Dim SelMethod As Boolean
SelMethod = ActiveSheet.OptionButton1.Value

'' BricsCADのキャプションを取得
Dim BcadCaption As String
BcadCaption = BcadDoc.Application.Caption
'' Excelのキャプションを取得
Dim xlApp As String
xlApp = Excel.Application.Caption
'' Excelのハンドルを取得
Dim XLhWnd As Long
XLhWnd = FindWindow(vbNullString, xlApp)

Dim SelectObj As AcadObject
Dim pt() As Double

'' BricsCADの画面をアクティブ
    AppActivate BcadCaption

On Error Resume Next

Do

If SelMethod = True Then

Call BcadDoc.Utility.GetEntity(SelectObj, pt(), "図形を選択: ")
If Err Then Exit Do

    Dim hatchObj As AcadHatch
    Dim patternType As AcPatternType
    Dim patternName As String
    Dim bAssociativity As Boolean
    
    patternType = acHatchPatternTypePreDefined  '定義されているパターン名から選択。
    patternName = Cells(5, 2).Value  'パターン名
    bAssociativity = True
    
    Set hatchObj = BcadDoc.ModelSpace.AddHatch _
        (patternType, patternName, bAssociativity)
        ''ﾌｧｲﾙ定義ﾊﾟﾀｰﾝ ､ ﾊﾟﾀｰﾝ名 ､ 自動調整する
    
    Dim outerLoop(0 To 0) As AcadEntity
    Set outerLoop(0) = SelectObj
    hatchObj.AppendOuterLoop (outerLoop)
    
    hatchObj.PatternScale = Cells(6, 2).Value
    hatchObj.PatternAngle = Cells(7, 2).Value * 4 * Atn(1) / 180
    
    ''Offset画層に変更
    hatchObj.Layer = SelLyr

    hatchObj.Evaluate
    BcadDoc.Regen True

Else

    '' 作図始点
        pt() = BcadDoc.Utility.GetPoint(, "図形内をクリック : ESCで終了 ")
        If Err Then Exit Do
        
        Dim objHatch As AcadHatch
        Dim Hatpat As String
        Dim HatSca As String
        Dim HatAng As String
        ''パターン名
        Hatpat = Cells(5, 2).Value
        HatSca = Cells(6, 2).Value
        HatAng = Cells(7, 2).Value
        
        ''画層をﾊｯﾁﾝｸﾞ用画層に変更する
        BcadDoc.SetVariable "CLAYER", SelLyr
        
        If Hatpat = "SOLID" Then
        
        BcadDoc.SendCommand "-BHATCH" & vbCr & "P" & vbCr & Hatpat & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr
        
        Else

        BcadDoc.SendCommand "-BHATCH" & vbCr & "P" & vbCr & Hatpat & _
            vbCr & HatSca & vbCr & HatAng & vbCr & pt(0) & "," & pt(1) & vbCr & vbCr
        
        End If

         ''画層を現在画層に戻す
        BcadDoc.SetVariable "CLAYER", CurLyr

End If


''図面を更新
BcadDoc.Application.Update

Loop

    Err.Clear
    On Error GoTo 0
    Set BcadApp = Nothing
    Set BcadDoc = Nothing
    Sleep 30
    ''Excelの画面をアクティブ
    Call BcadActive(WshShell, XLhWnd, xlApp)
    Set WshShell = Nothing

End Sub

Public Function BcadActive(WshShell, XLhWnd As Long, xlApp As String) As Boolean

''フォアグランドのタイトル
    Dim FGtitle As String
''現在フォアグラウンドになっているウィンドウハンドルを取得
    Dim FGHwnd As Long
    FGHwnd = GetForegroundWindow
''フォアグラウンドのタイトルバーテキストを格納
    FGtitle = String(100, Chr(0))
    GetWindowText FGHwnd, FGtitle, Len(FGtitle)
    ''フォアグランドタイトルがBricsCADの場合
    If FGtitle <> xlApp Then
        ''フォアグランドタイトルをExcelにする
        SetForegroundWindow (XLhWnd)
        ''「ALT+TAB」キーストロークを送りExcelを最前面にする
        Application.SendKeys "%{tab}", True
        ''NUMLOCK
        WshShell.SendKeys "{NUMLOCK}"
        Else
            AppActivate xlApp
        End If

End Function

以下続く・・・・

coffee break

Excelのウインドウが、作図終了後で、AppActivate で最前面にならず、タクスバーのアイコンがテカテカ点滅する場合が有ります。

GetForegroundWindow　で、現在フォアグラウンド（最前面）になっているウィンドウハンドルを取得し、GetWindowText　で、そのウィンドウハンドルからタイトルバーテキスト（＝キャプション）を取得すると・・・
フォアグラウンドのウィンドウが、Excelではなく、BricsCADになっている場合、AppActivate でExcelが最前面になりません。

SetForegroundWindowで、Zオーダーのトップ位置になりますが、最前面表示されないので、さらにSendKeys “%{tab}”,のウインドウ切り替えで、ようやく最前面表示できました。

SendKeysを使って以前検討していた時に、NUMLOCKがOFFになる現象について気付いていましたので、WSHShellでNUMLOCKを送っています。

BricsCAD VBAを使ってみよう　INDEX

BricsCAD VBAを使ってみよう[1]　VBAのｲﾝｽﾄｰﾙ

BricsCAD VBAを使ってみよう[2]　UserFormその１
「BricsCAD VBA 」Creating UserForm

BricsCAD VBAを使ってみよう[3]　UserFormその２
「BricsCAD VBA 」SerialNumber drawing with UserForm

BricsCAD VBAを使ってみよう[4]　VBAの基本コード①

BricsCAD VBAを使ってみよう[5]　VBAの基本コード②

BricsCAD VBAを使ってみよう[6]　Excelとの連携①
「BricsCAD VBA to Excel」Get_CoordinateValues

BricsCAD VBAを使ってみよう[7]　Excelとの連携②　
「Excel VBA to BricsCAD」Get_Area

BricsCAD VBAを使ってみよう[8]　Excelとの連携②-2　
「Excel VBA to BricsCAD」Draw_ChannelSteel

BricsCAD VBAを使ってみよう[9]　TABLEの自動作成と値入力
「BricsCAD VBA 」AutomaticCreation of TABLE

BricsCAD VBAを使ってみよう[10]　Excelとの連携②-3
「Excel VBA to BricsCAD」SerialNumber_Ⅱ

BricsCAD VBAを使ってみよう[11]　Excelとの連携②-4
「Excel VBA to BricsCAD」Draw_Rectang

BricsCAD VBAを使ってみよう[12]　Excelとの連携②-5 指定画層にOffset
「Excel VBA to BricsCAD」Continuous Offset to Specified Layer

BricsCAD VBAを使ってみよう[13]　Excelとの連携②-6 指定画層にHATCH
「Excel VBA to BricsCAD」Continuous Hatch to Specified Layer

BricsCAD VBAを使ってみよう[14]　Excelとの連携②-7　長さ計測
「Excel VBA to BricsCAD」Length measurement

BricsCAD VBAを使ってみよう[15]　Excelとの連携②-8　画層状態ｺﾝﾄﾛｰﾙ
「Excel VBA to BricsCAD」layer control

以下検討中です。

◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇
「この特集記事の内容につきましては、
こちらの環境のみの検討結果です。
動作保証は出来かねますため、ご参考
資料としてお扱いください。
Windows10（64bit）
BricsCAD pro V21（64bit）
Office2019（64bit）
◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇◇

Visited 61 times, 1 visit(s) today

テクノなブログページ

BricsCAD VBAを使ってみよう[13]　Excelとの連携②-6　指定画層にHatch

BricsCAD VBAを使ってみよう　INDEX

BricsCAD VBAを使ってみよう INDEX

BricsCAD VBAを使ってみよう　INDEX