SQLの窓

2017年08月06日


VBA : livedoor お天気API の JSON データを読み込んで利用する

InternetExplorer.Application 経由で JSON.parse を使用する方法 で、JSON 文字列をパースする方法は既にありますが、実用としてはプロパティを文字列段階で置換して、VB の予約語から排除する必要があります。その為に RegExp(VBScript.RegExp) を使用して _data をプロパティに付加します。

Sub ボタン1_Click()

    Dim objHttp As Object
    Dim strResult As String
    Dim objJSON As Object

    Dim lResolve As Long: lResolve = 60& * 1000
    Dim lConnect As Long: lConnect = 60& * 1000
    Dim lSend As Long: lSend = 60& * 1000
    Dim lReceive As Long: lReceive = 60& * 1000
    
    Set objHttp = CreateObject("Msxml2.ServerXMLHTTP")
    ' Livedoor のお天気情報(大阪)
    Call objHttp.Open("GET", "http://weather.livedoor.com/forecast/webservice/json/v1?city=270000", False)
    Call objHttp.setTimeouts(lResolve, lConnect, lSend, lReceive)
    Call objHttp.Send
    
    strResult = objHttp.responseText
    
    Set objReg = CreateObject("VBScript.RegExp")
    
    ' 全て置換
    objReg.Global = True
    ' パターン : () はサブマッチの範囲
    objReg.Pattern = """([^""]+)"":"
    
    ' $1 がサブマッチした文字列
    strResult = objReg.Replace(strResult, """$1_data""" & ":")
    
    Set objJSON = Parse(strResult)
    
    Set objHttp = Nothing
    
    MsgBox objJSON.title_data & " | " & objJSON.description_data.text_data

End Sub

Function Parse(json As String)

    Dim doc As Object, result As Object

    Set Ie = CreateObject("InternetExplorer.Application")
    Ie.Navigate ("about:blank")
    
    Do While Ie.Busy
        ' 100 ミリ秒
        Wscript.Sleep 100
    Loop
    
    Set doc = Ie.document
    
    doc.write "<script>document.JSON_Parse=function(s) {return JSON.parse(s);}</script>"
    
    Set Parse = doc.JSON_Parse(json)
    
    Ie.Quit
    
    Set Ie = Nothing

End Function






タグ:VBA VB EXCEL
posted by lightbox at 2017-08-06 00:13 | Comment(0) | VBA | このブログの読者になる | 更新情報をチェックする

2017年08月01日


VBA : シートの保護と部分的なセル入力の許可

現実問題として、Excel で運用を目的とした定型フォーマットのワークシートを用意しても、使用者が勝手にフォーマットを変えて混乱するという事は普通に起きます。その際、『シートの保護』を利用すると、パスワード無しではなにもできない状態にする事が可能です。

ただ、その際にも定型フォーマットの目的である機能は果たさなければならないので、部分的に入力可能にする必要があります。



その為には入力対象のセルに対してロックのチェックを外すという操作が手作業の場合は必要ですが、VBA で実行すると以下のようになります
    ' ********************
    ' データ処理をする Sheet
    ' ********************
    Dim objSheet As Worksheet

    On Error Resume Next
    Set objSheet = Worksheets("処理したいシート名")
    On Error GoTo 0


    ' ロック解除
    For I = 1 To 31 * 2 Step 2
    
        ' ロック解除(9行目のC列から開始して2行毎に1ヶ月ぶん)
        objSheet.Cells(I + 8, 3).Locked = False
    
    Next


また、VBA でワークシート内を変更する場合は、やはり保護されているとエラーとなるので処理の前で保護を解除し、処理の後で再度保護します。
    ' 保護を一旦解除
    objSheet.Unprotect "パスワード"
    
    ' 入力リストの解除とロック化
    For I = 1 To 31 * 2 Step 2
    
        objSheet.Cells(I + 8, 3).Validation.Delete
        Call objSheet.Cells(I + 8, 3).Validation.Add(xlValidateInputOnly, xlValidAlertStop, xlBetween)
        ' ロック
        objSheet.Cells(I + 8, 3).Locked = True
        
        ' クリア
        If objSheet.Cells(I + 8, 1).Value <> "" Then
            objSheet.Cells(I + 8 + 1, 4).Value = ""
            objSheet.Cells(I + 8 + 1, 8).Value = ""
        End If
    
    Next
    
    ' シート保護
    objSheet.Protect "パスワード"


このように、セル単位の設計をしておけば VBA で保護フォーマットを作成する事はとても容易に可能です。





タグ:VBA EXCEL VB
posted by lightbox at 2017-08-01 19:39 | Comment(0) | VBA | このブログの読者になる | 更新情報をチェックする

2017年07月25日


VBA : 挿入した『テキストボックス』にアクセスする



テキストボックスを挿入して、『オブジェクトと選択の表示』で一番下へ持って行って、コレクションの先頭に来るようにします( コレクションを For Each してもいいですが、ストレートに )

処理
Sub ボタン3_Click()


    MsgBox ActiveSheet.Shapes(1).TextFrame2.TextRange.Text
    
    Dim json As String
    
    json = "{" & vbCrLf
    json = json & vbTab & """link"": ""https://www.google.co.jp/""," & vbCrLf
    json = json & vbTab & """name"": ""Google""" & vbCrLf
    json = json & "}"
 
    ActiveSheet.Shapes(1).TextFrame2.TextRange.Text = json
  
  
End Sub

Form を使うのは面倒ですし、今時 Form でも無いだろうし、セルとこの方法でたいていの入力はまかなえると思います。

Shape オブジェクト (Excel)





タグ:VB VBA EXCEL
posted by lightbox at 2017-07-25 02:08 | Comment(0) | VBA | このブログの読者になる | 更新情報をチェックする

2017年07月24日


VBA : InternetExplorer.Application 経由で JSON.parse を使用する方法

InternetExplorer.Application は終了処理が面倒で、Visible を True にすると解りますが、処理がエラーで途中で終わってしまうとメモリ上に残ってしまって後の InternetExplorer.Application の処理に悪い影響が出ます。なので、毎回作成して解放するという処理方法で利用します。

InternetExplorer.Application から直接は JSON オブジェクトにアクセスできなかったので、以下のような形でアクセスしています。( Window オブジェクトは、Document.parentWindow で取得できます )

Json オブジェクトのプロパティに予約語(たとえばこの場合、text というプロパティ)を使用したら、VB のエディタが .Text と強制変換して実行時にエラーとなりました。なので、textdata というプロパティに変更してテストしました。

Sub ボタン1_Click()

    Dim doc As Object, result As Object

    Set Ie = CreateObject("InternetExplorer.Application")
    'Ie.Visible = True
    Ie.Navigate ("about:blank")
    
    Do While Ie.Busy
        ' 100 ミリ秒
        Wscript.Sleep 100
    Loop
    
    Set doc = Ie.document
    
    doc.write "<script>document.JSON_Parse=function(s) {return JSON.parse(s);}</script>"
    
    Dim str As String
    
    str = Cells(1, 1).Value
    
    Set result = doc.JSON_Parse(str)
    
    MsgBox (str)
    
    MsgBox (result.option.textdata)
    
    Ie.Quit
    
    Set Ie = Nothing

End Sub






タグ:VBA VB EXCEL
posted by lightbox at 2017-07-24 17:56 | Comment(0) | VBA | このブログの読者になる | 更新情報をチェックする

2017年07月23日


VBA : FileSystemObject でテキストファイル(CSV) を読み込んでセルにセットする

この記事は、『VBA : 一ヶ月の予定リストの作成』の続きです。
テンプレートシートをコピーして作業シートを作成する関数 "対象" という名前のシートがあればそれを使い、無ければ "テンプレート" シートをコピーして、"対象" と言う名前に変更します。
Function LoadSheet()
    
    ' ********************
    ' データ処理をする Sheet
    ' ********************
    Dim sheet As Worksheet
    
    ' ********************
    ' "対象" Sheet の取得
    ' ********************
    On Error Resume Next
    Set sheet = Worksheets("対象")
    On Error GoTo 0
    
    ' "対象" Sheet が無い場合は テンプレート をコピーして作成
    If sheet Is Nothing Then
        Call Worksheets("テンプレート").Copy(, Worksheets("年月入力"))
        ' コピーした Sheet の名前を変更
        Application.ActiveSheet.Name = "対象"
        ' 変数にコピーした Sheet をセット
        Set sheet = Application.ActiveSheet
    End If
    
    Set LoadSheet = sheet

End Function


※ 戻り値は、Worksheet オブジェクトです。

FileSystemObject は、ThisWorkbook に定義

Workbook_Open イベントで一度だけ実行して作成し、ブックを閉じるまでずっとそれを使います。

Public Fs As Object

Private Sub Workbook_Open()

    Set Fs = CreateObject("Scripting.FileSystemObject")

End Sub


※ Open から Line Input を使わないのは、FileSystemObject ならば 他の VB 系でも使用可能で汎用性が高いからです。

処理

※ Fs は、ThisWorkbook に定義されているので、ThisWorkbook.Fs と参照します
Sub ボタン2_Click()

    ' ********************
    ' データ処理をする Sheet
    ' ********************
    Dim sheet As Worksheet
    
    ' ********************
    ' 戻り値を取得
    ' ********************
    Set sheet = LoadSheet

    ' ********************
    ' ファイルを開く
    ' ********************
    Dim Path As String
    Path = Application.GetOpenFilename("CSV,*.csv,全て,*.*", , "CSVファイルを選択して下さい")
    If Path = "False" Then
        Exit Sub
    End If
    
    ' ********************
    ' オープン
    ' ********************
    On Error Resume Next
    Set InObj = ThisWorkbook.Fs.OpenTextFile(Path, 1)
    If Err.Number <> 0 Then
        MsgBox (Err.Description)
        Exit Sub
    End If
    On Error GoTo 0
    
    Dim Buffer As String
    Dim row As Integer: row = 0
    Dim Data() As String
    ' ********************
    ' CSV ファイルより
    ' データを読み込み
    ' ********************
    Do While Not InObj.AtEndOfStream
        Buffer = InObj.ReadLine
        
        row = row + 1
        
        Data = Split(Buffer, ",")
        
        sheet.Cells(row, 3).Value = Data(0)
        sheet.Cells(row, 4).Value = Data(1)
    Loop

    ' ********************
    ' ファイルクローズ
    ' ********************
    InObj.Close

End Sub


Application.GetOpenFilename の第二引数(FilterIndex)は省略しています。その代わり、第三引数を指定しています( タイトル文字列の指定 )

Split 関数
OpenTextFile メソッド
ReadLine メソッド






タグ:EXCEL VB VBA
posted by lightbox at 2017-07-23 20:57 | Comment(0) | VBA | このブログの読者になる | 更新情報をチェックする
container 終わり

フリーフォントで簡単ロゴ作成
フリーフォントでボタン素材作成
フリーフォントで吹き出し画像作成
フリーフォントではんこ画像作成
ほぼ自由に利用できるフリーフォント
フリーフォントの書体見本とサンプル
画像を大きく見る為のウインドウを開くボタンの作成

Android SDK ポケットリファレンス
改訂版 Webデザイナーのための jQuery入門
今すぐ使えるかんたん ホームページ HTML&CSS入門
CSS ドロップシャドウの参考デモ
Google Hosted Libraries
cdnjs
BUTTONS (CSS でボタン)
イラストAC
ぱくたそ
写真素材 足成
フリーフォント一覧
utf8 文字ツール
右サイド 終わり
base 終わり