連想配列

Dictionary オブジェクトが連想配列として使える。

  0
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 <%@ language="VBScript" %>
 <%
     ' HashTable.asp
     Dim HashTable
     Set HashTable = CreateObject("Scripting.Dictionary")
     HashTable.add "key1", "value1"
     HashTable.Item("key2") = "value2"
 
     Response.ContentType = "text/plain"
     Response.Charset = "Shift_JIS"
     Response.Expires = -1
 
     Response.write "key1: " & HashTable.Item("key1") & vbCRLF
     Response.write "key2: " & HashTable.Item("key2") & vbCRLF
 %>

既に存在するキーに対して、addメソッドを使うとエラーとなるが、Itemプロパティを使った場合には警告なく置き換えられる。

環境変数

環境変数を読み出すにはRequestオブジェクトServerVariablesコレクションを読み出せばよい。

  0
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 Browser = Request.ServerVariables ( "HTTP_USER_AGENT" )
 
 <html>
 <%@ language="VBScript" %>
 <!-- printEnv.asp -->
 <body>
 <table border="1">
 <tr><th>Server Variable</th><th>Value</th></tr>
 <% For Each strKey In Request.ServerVariables %>
 <tr><td><%= strKey %></td><td><%= Request.ServerVariables(strKey) %></td></tr>
 <% Next %>
 </table>
 </body>
 </html>

FileSystemObjectオブジェクト

FileSystemObjectオブジェクト

Webからのダウンロード

IXMLHTTPRequestオブジェクトを使って、指定したURIをダウンロードして表示する。

TinyProxy.asp?URI=http://xxx〜

charsetを返さないサーバに対して使用すると文字化けする。

  0
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 <%@ language="VBScript" %>
 <!-- #include File="adovbs.inc" -->
 <%
     ' TinyProxy.asp
 
     Response.ContentType = "text/html"
     Response.Charset = "Shift_JIS"
     Response.Expires = -1
 
     Dim sHTML
 
     sHTML = getURL( Request.QueryString("URI") )
 
     Response.Write sHTML
 
 ''''''''
 
     Function getURL( sURL )
         Dim oXMLHTTP, sHTML, sEncoding
         Set oXMLHTTP = Server.CreateObject("MSXML2.XMLHTTP")
 
         oXMLHTTP.Open "GET", sURL, False
         oXMLHTTP.Send
         sHTML = oXMLHTTP.responseBody
         sEncoding = oXMLHTTP.getResponseHeader("Content-type")
 
         Dim oRegExp
         Set oRegExp = New RegExp
         oRegExp.Pattern = ".*\s*charset=(.*)\s*"
         oRegExp.IgnoreCase = True
         oRegExp.Global = True
         If oRegExp.Test(sEncoding) Then
             sEncoding = oRegExp.Replace( sEncoding, "$1" )
         Else
             sEncoding = "Shift_JIS"
         End If
         Set oRegExp = Nothing
 
         Dim oStream
         Set oStream = Server.CreateObject("ADODB.Stream")
         oStream.Open
         oStream.Type = adTypeBinary
         oStream.Write sHTML
         oStream.Position = 0
         oStream.Type = adTypeText
         oStream.Charset = sEncoding
         getURL = oStream.ReadText()
         oStream.Close
         Set oStream = Nothing
 
         Set oXMLHTTP = Nothing
     End Function
 %>

(参考) ダウンロードしたHTMLを加工しない場合

  0
  1
  2
  3
  4
  5
     Dim oXMLHTTP
     Set oXMLHTTP = Server.CreateObject("MSXML2.XMLHTTP")
 
     oXMLHTTP.Open "GET", sURL, False
     oXMLHTTP.Send
     Response.BinaryWrite oXMLHTTP.responseBody

Excel からの CSV(K3フォーマット) 書き出し

SaveAsK3.bas

  0
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 Attribute VB_Name = "Module1"
 Private Const g_cnsDQ = """"
 Private Const g_cnsSQ = "'"
 Private Const g_cnsSH = "#"
 
 Private Const g_cnsEXT = ".txt"     ' 拡張子
 
 Sub SaveAsK3_csv()
     Call SaveAsK3(",", ".csv")
 End Sub
 
 Sub SaveAsK3(Optional separator As String = vbTab, Optional extension As String = g_cnsEXT)
 Attribute SaveAsK3.VB_Description = "すべてのシートをCSVとして書き出します。\n文字列は「""」でくくり、数値と日付はそのまま出力します。"
     Dim fh As Long                  'ファイルハンドル
     Dim myData As Range             'データ領域格納
     Dim myRecord As String          '出力するデータ(1行)
     Dim myField As String           '出力するデータ(1フィールド)
     Dim dataval As Variant          'データの値
     Dim datatype As String          'データの型
     Dim path As String              '出力パス
     Dim filename As String          '出力ファイル名
     Dim filenames As String         '出力ファイル名のリスト
     
     Dim w As Worksheet
     Dim i As Long, j As Long
     
     If ActiveWorkbook.path <> "" Then
         path = ActiveWorkbook.path & Application.PathSeparator
     Else
         path = CurDir & Application.PathSeparator
     End If
     filenames = ""
     
     For Each w In Worksheets
         'CSVファイル作成 (既存ファイルは上書き)
         filename = w.Name & extension
         fh = FreeFile
         Open path & filename For Output As #fh
         filenames = filenames & vbNewLine & filename
         'A1から始まる全データ範囲取得
         Set myData = w.Range("A1").CurrentRegion
         
         '範囲内の全行数ループ
         For i = 1 To myData.Rows.Count
             myRecord = ""
             '範囲内の1行ループ
             For j = 1 To myData.Columns.Count
                 dataval = myData(i, j).Value
                 datatype = TypeName(dataval)
                 ' 文字列は「"」でくくる
                 If datatype = "String" Then
                     myField = g_cnsDQ & dataval & g_cnsDQ
                 ' 日付はそのまま
                 ElseIf datatype = "Date" Then
                     'myField = g_cnsSH & dataval & g_cnsSH
                     myField = dataval
                 ' その他(Double,Empty,...)はそのまま
                 Else
                     myField = dataval
                 End If
                 
                 'データ格納
                 If j = 1 Then
                     '最初のデータ
                     myRecord = myField
                 Else
                     myRecord = myRecord & separator & myField
                 End If
             Next j
             
             'テキストファイル出力
             If myRecord <> "" Then
                 Print #fh, myRecord
             End If
         Next i
         Close #fh
     Next w
     MsgBox "ワークシートを書き出しました。" & vbNewLine & path & filenames, vbOKOnly, "処理終了"
     
     '変数開放
     Set dataval = Nothing
     Set myData = Nothing
 End Sub

ThisWorkbook.cls

  0
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 VERSION 1.0 CLASS
 BEGIN
   MultiUse = -1  'True
 END
 Attribute VB_Name = "ThisWorkbook"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = True
 Private Const g_cnsMenuName = "SaveAsK3"
 
 Private Sub Workbook_AddinInstall()
     On Error Resume Next
     Call Workbook_AddinUninstall
     Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
     Menu.Caption = g_cnsMenuName
     Set SubMenu1 = Menu.Controls.Add
     SubMenu1.Caption = "すべてのワークシートをタブ区切りファイルとして保存"
     SubMenu1.OnAction = "SaveAsK3"
     Set SubMenu2 = Menu.Controls.Add
     SubMenu2.Caption = "すべてのワークシートをカンマ区切りファイルとして保存"
     SubMenu2.OnAction = "SaveAsK3_csv"
 End Sub
 
 Private Sub Workbook_AddinUninstall()
     On Error Resume Next
     Application.CommandBars("Worksheet Menu Bar").Controls(g_cnsMenuName).Delete
 End Sub

Excel AddIn 作成のメモ

  • マクロの本体は「標準モジュール」に記述する。
  • メニューバーへの追加・削除イベントハンドラは「ThisWorkBook」に記述する。
  • 「ThisWorkBook」のプロパティの「IsAddin」を「True」にするとアドインとして認識される。
    「False」にすると通常のExcelファイルとして編集できる。(保護されていない場合)
  • プロジェクト名を「VBAProject」から変更しない。変更するとモジュール内の関数を見つけられなくなる。
  • アドインの保存場所
    %AppData%\Microsoft\AddIns

VBE.png

正規表現にマッチする部分を強調するアドイン

  • &ref(): File not found: "HighlightRegEx.zip" at page "VBScript";
    • HighlightRegEx.bas
        0
        1
        2
        3
        4
        5
        6
        7
        8
        9
       10
       11
       12
       13
       14
       15
       16
       17
       18
       19
       20
       21
       22
       23
       24
       25
       26
       27
       28
       29
       30
       31
       32
       33
       34
       35
      
      Attribute VB_Name = "Module1"
      Private Const defaultPattern = "\*[^\*]+\*"
       
      Sub HighlightRegEx()
        Dim pattern As String
        Dim selectedCells As Range
        Dim currentColor, selectedColor
        Dim isSetColor As Boolean
        Dim regEx, match
        Dim cell As Range
        pattern = InputBox("RegEx", "Highlight RegEx", defaultPattern)
        If pattern = "" Then
          Exit Sub
        End If
        Set selectedCells = Selection
        Selection(1).Select
        currentColor = Selection.Interior.color
        isSetColor = Application.Dialogs(xlDialogPatterns).Show
        selectedColor = Selection.Interior.color
        Selection.Interior.color = currentColor
        selectedCells.Select
        If isSetColor = False Then
          Exit Sub
        End If
        Set regEx = CreateObject("VBScript.RegExp")
        regEx.pattern = pattern
        regEx.Global = True
        For Each cell In selectedCells
          Set match = regEx.Execute(cell)
          If (match.Count > 0) Then
            For i = 0 To match.Count - 1
              cell.Characters(Start:=match(i).FirstIndex + 1, Length:=match(i).Length).Font.color = selectedColor
            Next
          End If
        Next cell
      End Sub
    • HighlightRegEx.cls
        0
        1
        2
        3
        4
        5
        6
        7
        8
        9
       10
       11
       12
       13
       14
       15
       16
       17
       18
       19
       20
       21
       22
       23
       24
       25
       26
       27
       28
       29
       30
       31
       32
       33
       34
       35
       36
       37
       38
       39
       40
      
      VERSION 1.0 CLASS
      BEGIN
        MultiUse = -1  'True
      END
      Attribute VB_Name = "ThisWorkbook"
      Attribute VB_GlobalNameSpace = False
      Attribute VB_Creatable = False
      Attribute VB_PredeclaredId = True
      Attribute VB_Exposed = True
       
      Private Const g_cnsMenuName = "Highlight RegEx"
       
      Private IsOffice15 As Boolean
       
      Private Sub Workbook_AddinInstall()
          On Error Resume Next
          Call Workbook_AddinUninstall
          Call AddToolBar
          If Application.Version >= 15 Then
              IsOffice15 = True
          End If
      End Sub
       
      Private Sub Workbook_Open()
          If IsOffice15 = True Then
              Call AddToolBar
          End If
      End Sub
       
      Private Sub AddToolBar()
          Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
          Menu.Caption = g_cnsMenuName
          Set SubMenu1 = Menu.Controls.Add
          SubMenu1.Caption = "Highlight parts matching with RegEx pattern in selection"
          SubMenu1.OnAction = "HighlightRegEx"
      End Sub
       
      Private Sub Workbook_AddinUninstall()
          On Error Resume Next
          Application.CommandBars("Worksheet Menu Bar").Controls(g_cnsMenuName).Delete
      End Sub

Excel VBA でプラットフォーム情報の取得

  0
  1
  2
  3
  4
  5
  6
 Sub showPlatform()
     Dim myOS As String
     Dim myVer As String
     myOS = Application.OperatingSystem
     myVer = Application.Version
     MsgBox "OS: " & myOS & vbNewLine & "Excel Version: " & myVer, vbOKOnly
 End Sub

Excel VBA で XML の読み取り

準備

  • Visual Basic Editor の「メニュー - ツール - 参照設定」で「Microsoft XML」にチェックを入れる。
    LibRefXML.png

ソース

  • fileLoadXML.zip
      0
      1
      2
      3
      4
      5
      6
      7
      8
      9
     10
     11
     12
     13
     14
     15
     16
     17
     18
     19
     20
     21
     22
     23
     24
     25
     26
     27
     28
     29
     30
     31
     32
     33
     34
     35
     36
     37
     38
     39
     40
     41
     42
     43
    
     Attribute VB_Name = "Module1"
     ' 初心者のための XML DOM ガイド
     ' http://msdn.microsoft.com/ja-jp/library/aa468547.asp
     
     Function LoadXML(Xml As String) As String
         Dim xDoc As MSXML2.DOMDocument
         Set xDoc = New MSXML2.DOMDocument
         xDoc.validateOnParse = False
         If xDoc.LoadXML(Xml) Then
             ' ドキュメントの読み込みに成功しました。
             ' 目的の作業を行います。
             LoadXML = ReadNode(xDoc.childNodes, 0)
             If Right(LoadXML, Len(vbCrLf)) = vbCrLf Then
                 LoadXML = Left(LoadXML, Len(LoadXML) - Len(vbCrLf))
             End If
         Else
             ' ドキュメントに読み込みに失敗しました。
             Dim xPE As MSXML2.IXMLDOMParseError
             Set xPE = xDoc.parseError
             With xPE
                 LoadXML = "エラー # : " & .errorCode & ": " & xPE.reason & _
                 "行 #: " & .Line & vbCrLf & _
                 "行位置 : " & .linepos & vbCrLf
             End With
             Set xPE = Nothing
         End If
         Set xDoc = Nothing
     End Function
     
     Function ReadNode(ByRef Nodes As MSXML2.IXMLDOMNodeList, ByVal Indent As Integer) As String
         ReadNode = ""
         Dim xNode As MSXML2.IXMLDOMNode
     
         For Each xNode In Nodes
             If xNode.nodeType = NODE_TEXT Then
                 ReadNode = ReadNode & Space$(Indent) & xNode.parentNode.nodeName & ": " & xNode.nodeValue & vbCrLf
                 'ReadNode = ReadNode & xNode.parentNode.nodeName & ":" & xNode.nodeValue & vbCrLf
             End If
     
             If xNode.hasChildNodes Then
                 ReadNode = ReadNode & ReadNode(xNode.childNodes, Indent + 2)
             End If
         Next xNode
     End Function

リンク

Access ファイル中のテーブルを列挙する

概要

  • Access ファイル(.mdb/.accdb)中のテーブル一覧を出力する。
  • ファイル名に加えてテーブル名も指定したときは、そのテーブルのカラム情報を出力する。

ソース

  • fileshowTables.zip
      0
      1
      2
      3
      4
      5
      6
      7
      8
      9
     10
     11
     12
     13
     14
     15
     16
     17
     18
     19
     20
     21
     22
     23
     24
     25
     26
     27
     28
     29
     30
     31
     32
     33
     34
     35
     36
     37
     38
     39
     40
     41
     42
     43
     44
     45
     46
     47
     48
     49
     50
     51
     52
     53
     54
     55
     56
     57
     58
     59
     60
     61
     62
     63
     64
     65
     66
     67
    
    ' Access ファイル中のテーブルを列挙する。
    ' http://hardsoft.at.webry.info/200908/article_6.html
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms681520.aspx
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms678060.aspx
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms675318.aspx
     
    Option Explicit
    Dim arg : Set arg = WScript.Arguments
    If arg.Count = 0 Then
        WScript.Echo "引数に mdb または accdb ファイル を指定してください"
        WScript.Quit
    End If
     
    Dim cn, cat, mdbfile
    mdbfile = arg(0)
    Set cn  = CreateObject("ADODB.Connection")
    With cn
        mdbfile = trim(mdbfile)
        If right(mdbfile,4) = ".mdb" Then
            .Provider = "Microsoft.Jet.OLEDB.4.0"
        ElseIf right(mdbfile,6) = ".accdb" Then
            .Provider = "Microsoft.ACE.OLEDB.12.0"
        End If
        .Properties("Data Source") = mdbfile
    End With
    cn.Open
     
    Set cat = CreateObject("ADOX.Catalog")
    cat.ActiveConnection = cn
     
    Dim table, tablename, column, datatype, sTypename
    Select Case (arg.Count)
    Case 1
        'WScript.Echo "Name" & vbTab & "Type"
        For Each table In cat.Tables
            If table.Type = "TABLE" Then
                'WScript.Echo table.Name & vbTab & table.Type
                WScript.Echo table.Name
            End If
        Next
    Case 2
        Set datatype = CreateObject("Scripting.Dictionary")
        datatype.add   2, "SmallInt"
        datatype.add   3, "Integer"
        datatype.add   5, "Double"
        datatype.add   6, "Currency"
        datatype.add   7, "DateTime"
        datatype.add  11, "Boolean"
        datatype.add  12, "Variant"
        datatype.add  14, "Decimal"
        datatype.add 200, "VarChar"
        datatype.add 201, "LongVarChar"
        datatype.add 202, "VarWChar"
        datatype.add 203, "LongVarWChar"
     
        tablename = arg(1)
        WScript.Echo "Name" & vbTab & "Type" & vbTab & "Size"
        Set table = cat.Tables(tablename)
        For Each column In table.Columns
            sTypename = column.Type
            If datatype.Exists(sTypename) Then sTypename = datatype(sTypename)
            WScript.Echo column.Name & vbTab & sTypename & vbTab & column.DefinedSize
        Next
    End Select
     
    cn.Close
     
    ' EOF
    

データベース

VBScript/Databaseを参照。

Base64 エンコード/デコード

BASE64のサンプルコード


添付ファイル: fileshowTables.zip 591件 [詳細] fileVBE.png 2361件 [詳細] fileLoadXML.zip 815件 [詳細] fileSaveAsK3.zip 786件 [詳細] fileLibRefXML.png 565件 [詳細]

リロード   新規 下位ページ作成 編集 凍結 差分 添付 コピー 名前変更   ホーム 一覧 検索 最終更新 バックアップ リンク元   ヘルプ   最終更新のRSS
Last-modified: Fri, 03 Mar 2017 15:59:17 JST (54d)