項目

AutoCAD-LTの制御

内容説明

CADソフトであるAutoCADはVBAが搭載されていてActiveXオブジェクトでもあるのでWord等と同じようにExcelVBAからActiveXオブジェクトへの参照を作成して完全に制御できます。
しかし、AutoCAD-LTの場合はVBAは搭載されていません。

そこで、手軽に利用出来るAutoCAD-LTをエクセルから制御する手段を示します。
エクセルをデータベースとして定型図面をパラメータを与えて描き、図面管理するアプリケーションを簡便に作る事が出来ます。
但し、当然ながらAutoCADをコマンドのみで操作できるスキルは必要です。

'AutoCAD-LTの制御
Option Explicit

'AutoCAD-LTにコマンドを送る
Sub test1_ControlAutoCadLT()
  On Error Resume Next
  AppActivate "AutoCAD LT" 'AutoCAD-LTをアクティブに
  If Err Then MsgBox "AutoCAD-LTが起動していません", , "AutoCAD-LT操作": Exit Sub
  DoEvents '←必要により
  SendKeys "line 200,200 400,400  ", True 'コマンドの例
  AppActivate ActiveWindow.Caption
End Sub

'AutoCAD-LTでファイルを開く
Sub test2_ControlAutoCadLT()
  Dim scr$, dwg$, ii&
  '開くファイル名の例
  dwg = "c:\ddd\eee\fff.dwg"
  'スプリクト作成の例
  scr = ThisWorkbook.Path & "\$!#tmp.scr"
  Open scr For Output As #1
  Print #1, "_open " & Chr(34) & dwg & Chr(34)
  Print #1, "filedia 1"
  Print #1, "zoom e"
  Close #1
  On Error Resume Next
  AppActivate "AutoCAD LT" 'AutoCAD-LTをアクティブに
  If Err Then MsgBox "AutoCAD-LTが起動していません", , "AutoCAD-LT操作": Exit Sub
  On Error GoTo 0
  'CADにスプリクト送る
  SendKeys "filedia 0" & vbCr & "script" & vbCr & Chr(34) & scr & Chr(34) & vbCr, True
  AppActivate ActiveWindow.Caption
  'スプリクトファイルを削除しなければ以下は不要(アプリ終了時にKillすればよい)
  Do 'scriptコマンドの終了を待つ
    DoEvents: Application.Wait Now + TimeValue("0:00:01")
    On Error Resume Next
    Kill scr
  Loop While Err = 70
End Sub

'AutoCAD-LTが起動していなければ起動する
Sub test3_ControlAutoCadLT()
  Dim out&
  If GetObject("winmgmts:").ExecQuery("SELECT Handle FROM Win32_Process WHERE Name = 'aclt.exe'").Count Then Exit Sub
  On Error Resume Next
  CreateObject("WScript.Shell").Run "aclt.exe" 'LTの起動
  If Err Then MsgBox "AutoCAD-LTを起動出来ません", , "AutoCAD-LT起動": Exit Sub
  On Error GoTo 0
  Do 'LTの起動を待つ
    DoEvents: Application.Wait Now + TimeValue("0:00:01")
    out = out + 1: If out = 10 Then Exit Do 'タイムアウト≒10s
    On Error Resume Next
    AppActivate "AutoCAD LT"
  Loop While Err
  AppActivate ActiveWindow.Caption
  If out <> 10 Then MsgBox "AutoCAD-LTを起動しました", , "AutoCAD-LT起動"
End Sub

項目

ファイルを開かないでシート名を取得する

内容説明

ファイルを普通に開かないでワークシート名を取得する方法です。
参照設定を要しない事後バインディングによるDAOを用いた簡単な記述の関数にしました。

'kWorksheetNames関数
'ブックを開かないでワークシート名を得る
'FileName：ブックのフルファイル名
'戻り値  ：ワークシート名のコレクション
Function kWorksheetNames(FileName As String) As Collection
  Dim co As New Collection, st$, tbl As Object
  With CreateObject("DAO.DBEngine.36").Workspaces(0).OpenDatabase(FileName, False, False, "Excel 8.0")
    For Each tbl In .TableDefs
      st = tbl.Name
      If Right(st, 1) = "$" Then
        st = Left(st, Len(st) - 1)
      ElseIf Left(st, 1) = "'" And Right(st, 2) = "$'" Then
        st = Mid(st, 2, Len(st) - 3)
      Else
        st = ""
      End If
      If Len(st) Then co.Add st
    Next
    .Close
  End With
  Set kWorksheetNames = co
End Function

'kWorksheetNames関数の使用例
Sub test_kWorksheetNames()
  Dim co As Collection, ful$, ii&
  ful = "c:\ddd\eee\fff.xls" 'フルネーム
  If Dir(ful) = "" Then Beep: Exit Sub
  Set co = kWorksheetNames(ful)
  Debug.Print ful
  Debug.Print "ワークシート数=" & co.Count
  For ii = 1 To co.Count
    Debug.Print co(ii)
  Next
End Sub

項目

データ フォームを表示する

内容説明

リストをデータベースとして使用する場合にデータ フォームをマクロにて表示する方法です。
リストの列ラベル(データベースのフィールド名)がA1から始まっている場合は、ShowDataFormメソッドで問題無くデータ フォームを表示出来ます。
　ActiveSheet.ShowDataForm
しかし、データベースがA1から始まっていない、複数存在する場合はShowDataFormメソッドは失敗します。
実行時エラー '1004':
Worksheet クラスの ShowDataForm メソッドが失敗しました。
が発生します。

データベースがA1から始まっていない、複数存在する場合はExcel4.0マクロにてデータ フォームを表示する事が出来ます。
目的のデーターベースのセル範囲の何れかをを選択して、
　ExecuteExcel4Macro "DATA.FORM()"
或いは、[データ]-[フォーム]コマンドをExecuteメソッドで実行でも可能です。
　Application.CommandBars.FindControl(ID:=860).Execute
なお、日付を表示形式"yyyy/m/d"で入力するにはExecuteメソッドで実行する必要があります。ShowDataFormメソッドでは表示形式"m/d/yyyy"での入力となってしまいます。

項目

新規シートのオブジェクト名を変更する

内容説明

新規シートのオブジェクト名を変更する方法を示します。
以下のマクロは対象ブックを指定して、指定した名前のシートを作成しオブジェクト名をシート名と同じに変更します。

Sub test1_E03M117()
  Dim sn$, wb As Workbook
  Set wb = ActiveWorkbook '対象のブック 例:Workbooks("Book1.xls")
  sn = "aaa" '作成するシート名
  If Not IsError(wb.Sheets(1).Evaluate(sn & "!a1")) Then Exit Sub 'シートは存在
  With wb.Sheets.Add
    .Name = sn
    With wb.VBProject: End With 'お呪い
    wb.VBProject.VBComponents(.CodeName).Name = sn 'オブジェクト名を変更
  End With
End Sub

追記：[_CodeName]プロパティ
Worksheetオブジェクトの隠しプロパティ[_CodeName]を用いる方法を示します。

Sub test2_E03M117()
  Dim sn$, wb As Workbook, ws As Worksheet
  Set wb = Workbooks("Book1.xls") '対象のブック 例:ActiveWorkbook
  sn = "bbb" '作成するシート名
  If Not IsError(wb.Sheets(1).Evaluate(sn & "!a1")) Then Exit Sub 'シートは存在
  Set ws = wb.Sheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
  With wb.VBProject: End With 'お呪い
  ws.Name = sn
  ws.[_CodeName] = sn 'オブジェクト名を変更
End Sub

項目

「マクロを無効にする/有効にする」ダイアログを出さずに起動する

内容説明

マクロが含まれるファイルを起動するときセキュリティレベルが中以上に設定されていると「マクロを無効にする/有効にする」ダイアログが表示されます。
特定のマクロファイルを開くときにセキュリティダイアログを出さない手段として他の実行ファイルを介して起動する方法があります。
実行ファイルとして拡張子がvbsやexe等のファイルが有りますが、vbsは業務や公開用には使いにくいのでやはりexeファイルを用いるのが最適です。

そこで起動用の汎用exeファイル「ExcelでありExcelでないアプリ」<kStart>を紹介します。
以下サイトよりkStartをダウンロードして任意のフォルダ(kstart等)へ解凍して下さい。 生成された kstart.exe を利用します。
kStartのVectorページ

利用法1：単にマクロファイルを起動する
マクロファイル名をapp1.xlsとして、app1.xlsと同じフォルダにkstart.exeを置いてapp1.exeと名前変更します。(マクロファイルと同名にする)
エクスプロ−ラ等からapp1.exeを実行します。

利用法2：起動時にスプラッシュウィンドウを表示する
マクロファイル名をapp2.xlaとして、app2.xlaと同じフォルダにkstart.exeを置いてapp2.exeと名前変更します。
ThisWorkbookモジュールには以下のような記述をしておきます。(一例)
Private Sub Workbook_Open()
　UserForm1.Show vbModeless
Workbooks.Add '実際はデータファイルを開く
　Application.Wait Now + TimeValue("0:00:05")
　Unload UserForm1
End Sub
エクスプロ−ラ等からapp2.exeを実行します。

利用法3：ユーザーフォームのみのアプリを起動する
マクロファイル名をapp3.xlaとして、app3.xlaと同じフォルダにkstart.exeを置いてapp3.exeと名前変更します。
ThisWorkbookモジュールには以下のような記述をしておきます。(一例)
Private Sub Workbook_Open()
　UserForm1.Show
　With Application
　　.WindowState = xlMinimized
　　.Quit
　End With
End Sub
エクスプロ−ラ等からapp3.exeを実行します。

kStartの仕様：(一部)
■ kstart.exeで起動されるマクロファイルは読み取り専用モードで開かれます。(プログラムファイルは運用時に上書き保存しない仕様による)
上書き保存する場合はThisWorkbookモジュールに以下を記述下さい。
Private Sub Workbook_Open()
　If ReadOnly Then ChangeFileAccess xlReadWrite
End Sub
■ 起動時のイベント
Auto_Openプロシージャは実行されません。他のWorkbook_Openプロシージャ等は実行されます。
■ エクセルは非表示で起動します
エクセルが一瞬も表示しない状態で、スプラッシュウィンドウの表示やコマンドバーの変更等が出来ます。

kStartの詳細は以下サイトをご参照下さい。
ExcelでありExcelでないアプリ<kStart>
マクロファイルに読み取りパスワードを設定する、xl?以外の拡張子を使う機能 及び組み込みツールの提供等を行います。(シェアウェア)

項目

「変更しようとしているセル〜」のダイアログを出さないようにする

内容説明

シートの保護(データ)をしてロックしたセルに入力しようとした場合「変更しようとしているセルまたはグラフは保護されているため読み取り専用となっています。･･･」のダイアログが表示されます。
この警告ダイアログを表示しない方法を示します。
定番処理のメモです

■Excel2002以降のバージョン
シート保護時に[ロックされたセルの選択の許可]のチェックを外します。

■Excel2000の場合
ワークシートのEnableSelectionプロパティにxlUnlockedCellsを設定します。
尚、ScrollAreaプロパティでスクロールが可能な領域を設定しておくとより良いインターフェイスとなります。
但し、EnableSelectionプロパティやScrollAreaプロパティはファイルに保存されませんのでファイルを開いた段階で設定してやる必要があります。

Workbook_Openイベントでの設定例
'ThisWorkbookモジュール
Private Sub Workbook()
  With Worksheets("Sheet1")
    .EnableSelection = xlUnlockedCells
    .ScrollArea = "a1:f10"
  End With
End Sub

項目

複数ウィンドウを親子の関係にする

内容説明

複数ウィンドウを親子の関係とは？
エクセルでユーザーフォームをモードレスで表示した場合の、エクセル本体ウィンドウとユーザーフォームウィンドウの関係が該当します。
親と子のウィンドウをそれぞれ切替えて操作出来て子ウィンドウは常に親ウィンドウの前面に表示されます。親ウィンドウを閉じると子ウィンドウも連携して自動的に閉じられます。
複数のモードレスユーザーフォームを表示した場合に親子の関係にする例を示します。

準備：UserForm1とUserForm2を配置、UserForm1にCommandButton1を配置
'標準モジュール
Option Explicit
Sub test_Tips114()
  UserForm1.Show vbModeless
End Sub

'UserForm1モジュール
Option Explicit
Private Declare Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" _
  (ByVal pacc As Object, phwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GWL_HWNDPARENT = (-8)

Private Sub CommandButton1_Click()
  Dim wnd1&, wnd2&
  Dim child As New UserForm2 '子とするUserForm
  WindowFromObject Me, wnd1
  WindowFromObject child, wnd2
  child.Show vbModeless
  'UserForm2をMeの子にする
  SetWindowLong wnd2, GWL_HWNDPARENT, wnd1
End Sub

ご参考： このコードは拙作Excelで電卓操作[k卓](ケイタク)にて用いているルーチンです。
エクセルと電卓(calc.exe)にて親子の関係を構築しています。
k卓のVectorページ

追記：VBEウィンドウにユーザーフォームを表示
VBEツールとしてユーザーフォームを表示したい場合、通常はEXCELウインドウ上に表示されるユーザーフォームをVBEウィンドウ上に表示する方法です。
この機能を実現するためによく見かけるのはEXCELウインドウを最小化している例ですがスマートではないです。心当たりの方は以下コードをご利用下さい。

'UserFormモジュール
Option Explicit
Private Declare Function WindowFromObject Lib "oleacc" Alias "WindowFromAccessibleObject" _
  (ByVal pacc As Object, phwnd As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Const GWL_HWNDPARENT = (-8)

Private Sub UserForm_Initialize()
  Dim wnd&
  WindowFromObject Me, wnd
  SetWindowLong wnd, GWL_HWNDPARENT, Application.VBE.MainWindow.hwnd
End Sub

項目

数値(Long)を2進数に変換

内容説明

数値(Long)を2進数に変換するkDec2Bin関数を示します。

'kDec2Bin関数
'数値(Long)を2進数に変換
'引数  ：num 数値
'戻り値：2進数の文字列
Function kDec2Bin(ByVal num As Long) As String
  Dim ss$, ii&, jj&, nn&
  nn = IIf(num < 0, num + 2147483648#, num)
  jj = 7 'jj+1 -> 2進数の桁数
  While Not (-2 ^ jj <= num And num < 2 ^ jj) '桁数を求める
    jj = jj + 8
  Wend
  For ii = 1 To jj
    ss = (nn Mod 2) & ss '2進数の文字列作成 0or1
    nn = nn \ 2
  Next
  kDec2Bin = IIf(num < 0, 1, 0) & ss
End Function

'kDec2Bin関数の使用例
Sub test_kDec2Bin()
  Debug.Print
  Debug.Print kDec2Bin(1), kDec2Bin(1)
  Debug.Print kDec2Bin(128), kDec2Bin(-128)
  Debug.Print kDec2Bin(32768), kDec2Bin(-32768)
End Sub

項目

印刷と印刷プレビューどちらが実行されたか

内容説明

[印刷]と[印刷プレビュー]のどちらがクリックされたかをアプリケーションレベルのWorkbookBeforePrintイベントで判定します。

'ThisWorkbookモジュール
Option Explicit
Private dpreview As Boolean 'プレビューのフラブ
Private WithEvents Preview As Office.CommandBarButton
Private WithEvents App As Application

Private Sub App_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean)
    Application.EnableEvents = False
  If dpreview Then
    MsgBox "[印刷プレビュー]が実行されます" 'Debug
    dpreview = False
  Else
    MsgBox "[印刷]が実行されます" 'Debug
    'Cancel = True 'Debug
  End If
  Application.EnableEvents = True
End Sub

Private Sub Preview_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
  dpreview = True
End Sub

Private Sub Workbook_Open()
  Set App = Application
  Set Preview = Application.CommandBars.FindControl(ID:=109) 'プレビュー
End Sub

項目

プロットエリアを中央に

内容説明

プロットエリアをグラフエリアの中央位置に表示する方法を示します。
kCenterPlotArea関数はInsideWidthやInsideLeftを用いた簡潔な方法ですが、これらのプロパティは整数で値(ポイント単位)が返されるため実行結果にやや精度が欠けます。 (1ポイント程度の誤差がでる場合がありますが実用に支障はありません)
kCenterPlotArea2関数はExcel4Macroを用いてDoubleで値(ポイント単位)を取得出来るため完全に正確な処理が出来ます。

'プロットエリアを中央に
Sub kCenterPlotArea()
  'If ActiveSheet.ChartObjects.Count = 0 Then Exit Sub
  On Error Resume Next
  With ActiveChart.PlotArea
    If Err Then MsgBox "チャートが選択されていません", , "プロットエリアを中央に": Exit Sub
    On Error GoTo 0
    .Left = (.Parent.ChartArea.Width - .InsideWidth) / 2 - .InsideLeft + .Left
    .Top = (.Parent.ChartArea.Height - .InsideHeight) / 2 - .InsideTop + .Top
  End With
End Sub

'プロットエリアを中央に(2)
Sub kCenterPlotArea2()
  Dim wi#, he#, le#, bo#
  On Error Resume Next
  ActiveChart.ChartArea.Select
  If Err Then MsgBox "チャートが選択されていません", , "プロットエリアを中央に": Exit Sub
  On Error GoTo 0
  ActiveChart.PlotArea.Select
  With Application
    wi = .ExecuteExcel4Macro("GET.CHART.ITEM(1,5)") - .ExecuteExcel4Macro("GET.CHART.ITEM(1,1)")
    he = .ExecuteExcel4Macro("GET.CHART.ITEM(2,1)") - .ExecuteExcel4Macro("GET.CHART.ITEM(2,5)")
    With ActiveChart.ChartArea
      le = (.Width - wi) / 2
      bo = (.Height - he) / 2
    End With
    .ExecuteExcel4Macro "FORMAT.MOVE(" & le & "," & bo & ")"
  End With
  ActiveChart.ChartArea.Select
End Sub

追記：プロットエリアを正方形にする
応用の簡単な例としてプロットエリアを正方形にするkPlotAreaSquare関数を示します。チャートの複数選択に対応しています。


'プロットエリアを正方形にする(複数選択対応)
Sub kPlotAreaSquare()
  Dim co As ChartObject, nn&
  If Not ActiveChart Is Nothing Then
    pPlotAreaSquare ActiveChart
    Exit Sub
  End If
  If TypeName(Selection) = "DrawingObjects" Then
    For Each co In Selection
      'Debug.Print TypeName(co)
      If TypeName(co) = "ChartObject" Then
        pPlotAreaSquare co.Chart
        nn = nn + 1
      End If
    Next
  End If
  If nn = 0 Then _
    MsgBox "チャートが選択されていません", , "プロットエリアを正方形にする"
End Sub
Private Sub pPlotAreaSquare(ch As Chart)
  With ch
    .ChartArea.AutoScaleFont = False 'フォントサイズを自動変更しない
    With .PlotArea
      If .InsideWidth < .InsideHeight Then
        .Height = .Height - .InsideHeight + .InsideWidth
      Else
        .Width = .Width - .InsideWidth + .InsideHeight
      End If
    End With
  End With
End Sub

エクセルVBAテクニック集[kVBA2]グラフ編