半角チルダ

ExcelVBA、その他。
覚え書きや、補足資料などのスクラップブック。
end-u(1037781)

■VBA VB_ProcData.VB_Invoke_Func

2010-12-03 20:00:00 | scrap
#[Visual Basic プロジェクトへのアクセスを信頼する]シリーズ :)


'ActiveWorkbookのマクロショートカットキーを列挙。
Sub try()
  Const vbext_ct_StdModule = 1 '標準Module
  Dim vbc As Object      'VBIDE.VBComponent
  Dim tmp As String
  Dim cnt As Long
  Dim n  As Long
  Dim i  As Long
  Dim buf() As String
  Dim ret(0 To 100, 1 To 2) As String

  On Error GoTo extLine
  ret(0, 1) = "Module"
  ret(0, 2) = "VB_Invoke_Func"
  tmp = Application.DefaultFilePath & "\" & CLng(Date) & "temp.tmp"
  With ActiveWorkbook
    For Each vbc In .VBProject.VBComponents
      With vbc
        If .Type = vbext_ct_StdModule Then
          .Export tmp
          n = FreeFile
          Open tmp For Input As #n
          buf = Split(StrConv(InputB(LOF(n), #n), vbUnicode), vbCrLf)
          Close #n
          Kill tmp
          For i = 0 To UBound(buf)
            If buf(i) Like "Attribute*.VB_Invoke_Func*" Then
              cnt = cnt + 1
              ret(cnt, 1) = .Name
              ret(cnt, 2) = buf(i)
            End If
          Next
        End If
      End With
    Next
  End With
  If cnt > 0 Then
    '新規Bookに列挙
    With Workbooks.Add(xlWBATWorksheet).Sheets(1).Range("A1").Resize(cnt + 1, 2)
      .Value = ret
      .Columns.AutoFit
    End With
  Else
    MsgBox "no data"
  End If
  
extLine:
  Set vbc = Nothing
  With Err()
    If .Number <> 0 Then
      MsgBox .Number & "::" & .Description
    End If
  End With
End Sub
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

■VBA VBProject.VBComponents

2010-12-02 20:00:00 | scrap
#[Visual Basic プロジェクトへのアクセスを信頼する]必要があります。


'ActiveWorkbookのプロシージャリスト列挙
'TEST中、何度かExcelが落ちたのでステップ実行は危険。
Sub GetProcLst()
  Const vbext_ct_StdModule = 1  '標準Module
  Const vbext_ct_ClassModule = 2 'ClassModule
  Const vbext_ct_MSForm = 3   'FormClassModule
  Const vbext_ct_Document = 100 'Book|SheetModule
  Const vbext_pk_Proc = 0    'Sub|Function プロシージャ
  Dim vbc As Object       'VBIDE.VBComponent
  Dim tmp As String
  Dim cnt As Long
  Dim mx As Long
  Dim i  As Long
  Dim j  As Long
  Dim k  As Long
  Dim v
  Dim ret(0 To 1000, 1 To 5) As String

  On Error GoTo extLine
  For Each v In Array("Book", "Module", "Type", "Procedure", "Arg")
    i = i + 1
    ret(0, i) = v
  Next
  cnt = 1
  With ActiveWorkbook
    For Each vbc In .VBProject.VBComponents
      'Select Case vbc.Type
      'Case vbext_ct_StdModule, vbext_ct_Document
        ret(cnt, 1) = .Name
        ret(cnt, 2) = vbc.Name
        ret(cnt, 3) = vbc.Type
        With vbc.CodeModule
          mx = .CountOfLines
          i = 1
          Do Until i > mx
            tmp = .ProcOfLine(i, vbext_pk_Proc)
            If tmp = "" Then
              i = i + 1
            Else
              j = .ProcBodyLine(tmp, vbext_pk_Proc)
              ret(cnt, 4) = tmp
              ret(cnt, 5) = .Lines(j, 1)
              k = j
              Do Until Right$(ret(cnt, 5), 2) <> " _"
                k = k + 1
                ret(cnt, 5) = ret(cnt, 5) & vbLf & .Lines(k, 1)
              Loop
              i = j + .ProcCountLines(tmp, vbext_pk_Proc)
              cnt = cnt + 1
            End If
          Loop
        End With
      'End Select
    Next
  End With
  '新規Bookに列挙
  With Workbooks.Add(xlWBATWorksheet).Sheets(1).Range("A1").Resize(cnt, 5)
    .Value = ret
    .Columns.AutoFit
    .Rows.AutoFit
  End With

extLine:
  Set vbc = Nothing
  With Err()
    If .Number <> 0 Then
      MsgBox .Number & "::" & .Description
    End If
  End With
End Sub

他、参考情報。
『[XL97] モジュール、プロシージャの情報取得および操作方法』
http://support.microsoft.com/kb/410621/ja
『Visual Basic 6.0 を使用して Excel ブックに格納されているマクロの名前を取得する方法』
http://support.microsoft.com/kb/315731/ja
『Excel 2003 および Excel 2007 で Visual Basic プロジェクトへのアクセスをプログラミングにより許可すると実行時エラーが表示される場合がある』
http://support.microsoft.com/kb/813969/ja
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする

■VBA TLI.TLIApplication

2010-12-01 21:00:00 | scrap
■組み込み定数の数値から文字列定数を取得の焼き直し。

昨日のリストを元にしてもよいですが、
『Office アプリケーションの組み込み定数の値を取得する方法』
http://support.microsoft.com/kb/239930/ja
タイプライブラリ情報から組み込み定数を列挙するサンプル。

まずは定数の各クラス名列挙

'#TLBINF32.DLLが在る環境のみ
Sub try1()
  Dim aPath As String
  
  'Excel
  aPath = "C:\Program Files\OFFICE11\EXCEL.EXE"
  'Office
  'aPath = "C:\Program Files\Common Files\Microsoft Shared\OFFICE11\MSO.DLL"
  Call sConstName(aPath)
End Sub
'---------------------------------------------------------------------
Sub sConstName(ByVal aPath As String)
  Dim TLI As Object
  Dim cnt As Long
  Dim i  As Long
  Dim ret() As String
  
  On Error GoTo extLine
  Set TLI = CreateObject("TLI.TLIApplication").TypeLibInfoFromFile(aPath)
  With TLI.Constants
    cnt = .Count
    ReDim ret(1 To cnt, 0)
    For i = 1 To cnt
      ret(i, 0) = .Item(i).Name
      'Debug.Print .Item(i).Name
    Next
  End With
  '新規Book追加して列挙
  With Workbooks.Add(xlWBATWorksheet).Sheets(1).Range("A1").Resize(cnt)
    .Value = ret
    .Columns.AutoFit
  End With
  
extLine:
  Erase ret
  Set TLI = Nothing
  With Err()
    If .Number <> 0 Then
      MsgBox .Number & "::" & .Description
    End If
  End With
End Sub

クラス名決め打ちで定数を列挙

'#TLBINF32.DLLが在る環境のみ
Sub try2()
  Dim aPath As String
  Dim x   As Long

  With Application
    x = Val(.Version)
    If x > 9 Then
      aPath = .Path & "\EXCEL.EXE"
    Else
      aPath = .Path & "\EXCEL" & CStr(x) & ".OLB"
    End If
  End With
  Call sConstStr(aPath, "XlChartType")
End Sub
'---------------------------------------------------------------------
Sub sConstStr(ByVal aPath As String, ByVal cName As String)
  Dim TLI As Object
  Dim cnt As Long
  Dim i  As Long
  Dim ret() As String

  On Error GoTo extLine
  Set TLI = CreateObject("TLI.TLIApplication").TypeLibInfoFromFile(aPath)
  With TLI.Constants.NamedItem(cName).Members
    cnt = .Count
    ReDim ret(1 To cnt, 1 To 2)
    For i = 1 To cnt
      With .Item(i)
        ret(i, 1) = .Value
        ret(i, 2) = .Name
        'Debug.Print .Value, .Name
      End With
    Next
  End With
  '新規Book追加して列挙
  With Workbooks.Add(xlWBATWorksheet).Sheets(1).Range("A1").Resize(cnt, 2)
    .Value = ret
    .Columns.AutoFit
  End With
  
extLine:
  Erase ret
  Set TLI = Nothing
  With Err()
    If .Number <> 0 Then
      MsgBox .Number & "::" & .Description
    End If
  End With
End Sub

他、参考情報。
『[FILE] プログラムによる DLL クラスのメンバの取得』
http://support.microsoft.com/kb/172988/ja
『■ VBAで関数の参照を得るには?』
http://homepage1.nifty.com/MADIA/vb/vb_bbs2/200511/200511_05110142.html
Comment
  • X
  • Facebookでシェアする
  • はてなブックマークに追加する
  • LINEでシェアする