読者です 読者をやめる 読者になる 読者になる

PeaceJetのブログ

金融系の社内エンジニアをやりながら、マーケティングやプランナーなども

【VBA】戻り値を変数に格納しなかったら、えらいめにあった。

戻り値をオブジェクトに格納しなかったら、えらいめにあった。

なんか、当たり前のことではあるのですが、ハマりました(笑)

以下のファンクション・プロシージャとサブ・プロシージャを同じモジュ―ルに配置して、実行してみて下さい。

Private Function returnValue()
    
    Dim i As Long
    For i = 0 To 1
        If i = 0 Then
            returnValue = True
        ElseIf i = 1 Then
            returnValue = False
        End If
    Next i
    
End Function
Public Sub returnTest()

If returnValue = True Then
    Debug.Print returnValue
ElseIf returnValue = False Then
    Debug.Print returnValue
End If

End Sub


イミディエイトウインドウには以下のように表示されそうのように思いますよね?
自分だけかな?

'True
'False

でも、実際はFalseしか表示されません。

ファンクション・プロシージャの中身が再評価されてしまうためです。

それでは、どのようにコード改変すれば上記のように出力されるのでしょうか?

Public Sub returnTest()

Select Case returnValue
    Case True
        Debug.Print returnValue
    Case False
        Debug.Print returnValue
End Select

End Sub

Select Case文を使うことで回避することが出来ます。

あるいは、何かの変数に格納してしまえばいいのです。

【VBA】WordとExcelのコラボレーション

Wordの文章をExcelから置換する方法

ほんと、毎日、こんなことばかりやっていて辛い。
ExcelからWordの文章を開いて、Excelからワードの文章中の文言を任意のものへ変更したい。

そんな要望があったので、作ってみました。

Word側はExcel側から検索できるように、置換したい部分を変更しておきます。
(以下を参照)

f:id:PeaceJet:20170511120634p:plain

参照設定からMicrosoft Scripting Runtime」にチェックを入れて下さい。

Sub ReplaceSentenceOnWordApp()

    Const FilePath As String = "" 'Excelファイルパス
    Dim wordObject As Object: Set wordObject = CreateObject("Word.Application")
    Dim wordApp As Object: Set wordApp = wordObject.Documents.Open(FilePath)
    Dim TargetText As String: TargetText = "{Name}"
    Dim ReplaceText As String: ReplaceText = "田中"
    
    wordObject.visible = True
    
    With wordApp.Content.Find
        .Text = TargetText
        .Replacement.Text = ReplaceText
        .wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With

End Sub

適当にモジュールにコピーして、実行すれば動くはずです!

お試しあれ!

【GAS】Googleカレンダーへ終日イベントを登録する!

最近は、Google Apps Scriptを業務で使うようになってきました。

Googleカレンダーへの登録もGoogle Calendar APIを活用すれば一発!

ファイト一発なんだよ!

失礼しました。

GASで終日イベントを登録

f:id:PeaceJet:20170503022227p:plain

さて、上記のようなテーブルがあるとします。

以下のコードでは・・・
「◯」がついている日に、それぞれのイベント名をGoogleカレンダーのタイトルとして登録できます。

※注意※


1.「リソース」→「Googleの拡張サービス」→「Google Calendar API」を有効にして下さい。
2.「Google API コンソール」でも有効にして下さい。

スクリプトエディタを開いて、初期状態では「コード.gs」となっていると思いますが、そのままでも大丈夫です。

function AddEvent() {
  
  var sheet = SpreadsheetApp.getActiveSpreadsheet().getActiveSheet();
  var lastRow = sheet.getLastRow();
  var lastColum = sheet.getLastColumn();
  var CalendarID = ""; //カレンダーID
  var Calendar = CalendarApp.getCalendarById(CalendarID);
  
  for (var x = 2; x <= lastColum; x++) {
    for (var y = 2; y <= lastRow; y++) {
      
      var Val = sheet.getRange(y, x).getValue();
      
      if (Val != "") {
        var Title = sheet.getRange(1, x).getValue();
        var Event = sheet.getRange(y, 1).getValue();
        
        Calendar.createAllDayEvent(Title, new Date(Event));
        
      }
      
    }
  }
}
追伸

Dateの部分で、いつも詰まってしまいます(笑)
皆様の役にたてば幸いです。

【VBA】一つのカラム名に対して複数値のJSONを生成するコード

VBAJSONを生成したい

一つのカラム名に対して複数の値が存在するような場合について、JSONを生成するという需要がありましたので共有します。

例えば、Sheet1に以下のような値が入っているとします。

f:id:PeaceJet:20170425190901p:plain

この状態で、下記のような結果が欲しい場合は、これから紹介するコードが役に立つでしょう。

'以下のような、結果が返ります。
'{"ID":"1","NAME":"hoge","DETAIL":["fuga","fizz","buzz"]}


ただ、注意点があります。
それは、IDの列が2、3・・・と増加する場合の対応が出来ていないことです。

これは、Function名にJsonPostとあるように、VBAからPost送信をする際の使用を前提としているので、そこまでの機能拡張を視野に入れていないからです。

Jsonを送信するなら、この程度あれば十分かなということで作りました。

Function JsonPost()

    sName = "Sheet1"
    
    'Worksheetをセット
    Dim Ws As Worksheet: Set Ws = ThisWorkbook.Sheets(sName)
    'CurrentRegion
    Dim Region As Variant: Region = Ws.Cells(1, 1).CurrentRegion
    '行列の数
    Dim rLength, cLength As Long: rLength = UBound(Region, 1): cLength = UBound(Region, 2)
    
    '見出し
    ReDim Fields(cLength - 1)
    
    'データの取得とJSON生成
    Dim i As Long
    For i = 1 To cLength
        '1行目の各セルを見出しとして取得。
        Fields(i - 1) = Region(1, i)
    Next i
    
    Dim x, y As Long
    ReDim Temps(cLength - 1)
    
    For x = 1 To cLength
        
        Dim LastRows As Long: LastRows = Ws.Cells(100, x).End(xlUp).Row
        Dim FieldName As String: FieldName = Chr(34) & Fields(x - 1) & Chr(34) & ":"
        
        '値
        ReDim Values(LastRows - 2)
        For y = 2 To LastRows
            Values(y - 2) = Chr(34) & Ws.Cells(y, x) & Chr(34)
        Next y
        
        'DETAILの時は、配列にする。
        If FieldName = Chr(34) & "DETAIL" & Chr(34) & ":" Then
            Temps(x - 1) = FieldName & "[" & Join(Values, ",") & "]"
        Else
            Temps(x - 1) = FieldName & Join(Values, ",")
        End If

    Next x
    
    JsonPost = "{" & Join(Temps, ",") & "}"

End Function

【VBA】HMAC-SHAを生成する方法

VBAでHMAC-SHAの値を取得する

VBAを使って、HMAC-SHAの値を取り出すことに苦戦したので共有します。

'
'以下のコードを標準モジュールに貼り付ける。
'

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" _
                            (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, _
                             ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" _
                            (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" _
                            (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, _
                             ByRef phHash As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" _
                            (ByVal hHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" _
                            (ByVal hHash As Long, pbData As Any, ByVal cbData As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" _
                            (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByRef pcbData As Long, _
                             ByVal dwFlags As Long) As Long

Private Const PROV_RSA_FULL   As Long = 1
Private Const PROV_RSA_AES    As Long = 24
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000

Private Const HP_HASHVAL      As Long = 2
Private Const HP_HASHSIZE     As Long = 4

Private Const ALG_TYPE_ANY    As Long = 0
Private Const ALG_CLASS_HASH  As Long = 32768

Private Const ALG_SID_MD2     As Long = 1
Private Const ALG_SID_MD4     As Long = 2
Private Const ALG_SID_MD5     As Long = 3
Private Const ALG_SID_SHA     As Long = 4
Private Const ALG_SID_SHA_256 As Long = 12
Private Const ALG_SID_SHA_384 As Long = 13
Private Const ALG_SID_SHA_512 As Long = 14

Private Const CALG_MD2        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD2)
Private Const CALG_MD4        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD4)
Private Const CALG_MD5        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5)
Private Const CALG_SHA        As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA)
Private Const CALG_SHA_256    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_256)
Private Const CALG_SHA_384    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_384)
Private Const CALG_SHA_512    As Long = (ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_SHA_512)

' Create Hash
Private Function CreateHash(abytData() As Byte, ByVal lngAlgID As Long) As String
    Dim hProv As Long, hHash As Long
    Dim abytHash(0 To 63) As Byte
    Dim lngLength As Long
    Dim lngResult As Long
    Dim strHash As String
    Dim i As Long
    strHash = ""
    If CryptAcquireContext(hProv, vbNullString, vbNullString, _
                           IIf(lngAlgID >= CALG_SHA_256, PROV_RSA_AES, PROV_RSA_FULL), _
                           CRYPT_VERIFYCONTEXT) <> 0& Then
        If CryptCreateHash(hProv, lngAlgID, 0&, 0&, hHash) <> 0& Then
            lngLength = UBound(abytData()) - LBound(abytData()) + 1
            If lngLength > 0 Then lngResult = CryptHashData(hHash, abytData(LBound(abytData())), lngLength, 0&) _
                             Else lngResult = CryptHashData(hHash, ByVal 0&, 0&, 0&)
            If lngResult <> 0& Then
                lngLength = UBound(abytHash()) - LBound(abytHash()) + 1
                If CryptGetHashParam(hHash, HP_HASHVAL, abytHash(LBound(abytHash())), lngLength, 0&) <> 0& Then
                    For i = 0 To lngLength - 1
                        strHash = strHash & Right$("0" & Hex$(abytHash(LBound(abytHash()) + i)), 2)
                    Next
                End If
            End If
            CryptDestroyHash hHash
        End If
        CryptReleaseContext hProv, 0&
    End If
    CreateHash = LCase$(strHash)
End Function

' Create Hash From String(Shift_JIS)
Private Function CreateHashString(ByVal strData As String, ByVal lngAlgID As Long) As String
    CreateHashString = CreateHash(StrConv(strData, vbFromUnicode), lngAlgID)
End Function

' Create Hash From File
Private Function CreateHashFile(ByVal strFileName As String, ByVal lngAlgID As Long) As String
    Dim abytData() As Byte
    Dim intFile As Integer
    Dim lngError As Long
    On Error Resume Next
        If Len(Dir(strFileName)) > 0 Then
            intFile = FreeFile
            Open strFileName For Binary Access Read Shared As #intFile
            abytData() = InputB(LOF(intFile), #intFile)
            Close #intFile
        End If
        lngError = Err.Number
    On Error GoTo 0
    If lngError = 0 Then CreateHashFile = CreateHash(abytData(), lngAlgID) _
                    Else CreateHashFile = ""
End Function

' MD5
Public Function CreateMD5Hash(abytData() As Byte) As String
    CreateMD5Hash = CreateHash(abytData(), CALG_MD5)
End Function
Public Function CreateMD5HashString(ByVal strData As String) As String
    CreateMD5HashString = CreateHashString(strData, CALG_MD5)
End Function
Public Function CreateMD5HashFile(ByVal strFileName As String) As String
    CreateMD5HashFile = CreateHashFile(strFileName, CALG_MD5)
End Function

' SHA-1
Public Function CreateSHA1Hash(abytData() As Byte) As String
    CreateSHA1Hash = CreateHash(abytData(), CALG_SHA)
End Function
Public Function CreateSHA1HashString(ByVal strData As String) As String
    CreateSHA1HashString = CreateHashString(strData, CALG_SHA)
End Function
Public Function CreateSHA1HashFile(ByVal strFileName As String) As String
    CreateSHA1HashFile = CreateHashFile(strFileName, CALG_SHA)
End Function

' SHA-256
Public Function CreateSHA256Hash(abytData() As Byte) As String
    CreateSHA256Hash = CreateHash(abytData(), CALG_SHA_256)
End Function
Public Function CreateSHA256HashString(ByVal strData As String) As String
    CreateSHA256HashString = CreateHashString(strData, CALG_SHA_256)
End Function
Public Function CreateSHA256HashFile(ByVal strFileName As String) As String
    CreateSHA256HashFile = CreateHashFile(strFileName, CALG_SHA_256)
End Function

' SHA-384
Public Function CreateSHA384Hash(abytData() As Byte) As String
    CreateSHA384Hash = CreateHash(abytData(), CALG_SHA_384)
End Function
Public Function CreateSHA384HashString(ByVal strData As String) As String
    CreateSHA384HashString = CreateHashString(strData, CALG_SHA_384)
End Function
Public Function CreateSHA384HashFile(ByVal strFileName As String) As String
    CreateSHA384HashFile = CreateHashFile(strFileName, CALG_SHA_384)
End Function

' SHA-512
Public Function CreateSHA512Hash(abytData() As Byte) As String
    CreateSHA512Hash = CreateHash(abytData(), CALG_SHA_512)
End Function
Public Function CreateSHA512HashString(ByVal strData As String) As String
    CreateSHA512HashString = CreateHashString(strData, CALG_SHA_512)
End Function
Public Function CreateSHA512HashFile(ByVal strFileName As String) As String
    CreateSHA512HashFile = CreateHashFile(strFileName, CALG_SHA_512)
End Function

hmac_sha関数で値を取り出す

次に、独自関数になりますがhmac_sha関数を使用して値を取り出します。

Public Function HMAC_SHA1(ByVal Key As String, ByVal Secret As String) As String

Dim InPad, OuPad As String: InPad = "": OuPad = ""
Dim i As Integer

Dim SecretArray() As Byte
ReDim SecretArray(0 To 63)

For i = 0 To Len(Secret) - 1
  SecretArray(i) = Asc(Mid(Secret, i + 1, 1))
Next

For i = Len(Secret) To 63
  SecretArray(i) = 0
Next

For i = 0 To 63
  InPad = InPad & Chr(SecretArray(i) Xor &H36)
  OuPad = OuPad & Chr(SecretArray(i) Xor &H5C)
Next

Dim hash As String: hash = CreateSHA1HashString(InPad & Key)
Dim BufferArray() As Byte: BufferArray = StrConv(OuPad, vbFromUnicode)
Dim Offset As Integer: Offset = UBound(BufferArray)

ReDim Preserve BufferArray(Offset + Len(hash) \ 2)

For i = 1 To (Len(hash) \ 2)
  BufferArray(Offset + i) = CByte("&H" & Mid(hash, (i - 1) * 2 + 1, 2))
Next i

HMAC_SHA1 = CreateSHA1Hash(BufferArray)

End Function

【VBA】UNIX時間の求め方(エポック秒)【PHP】

こんにちは、PeaceJetです。
この度、PHPで書かれたプログラムをVBA上に落とし込まなければならないというプロジェクトが発生。
そこで、UNIX時間を求めなければならず、四苦八苦したので共有します。

PHPでのUNIX時間の求め方

<?php
echo Time()
?>
このとき出力されるのはUTC協定世界時

協定世界時(きょうていせかいじ、UTC, 英語: Coordinated Universal Time, ドイツ語: Koordinierte Weltzeit, フランス語: Temps Universel Coordonné)とは、国際原子時 (TAI) に由来する原子時系の時刻で、UT1 世界時に同調するべく調整された基準時刻を指す。

※引用のため一部修正

協定世界時 - Wikipedia


協定世界時で出力されていることから、GMTでもなければJSTでもありません。

グリニッジ平均時(グリニッジへいきんじ、イギリス英語: Greenwich Mean Time, GMT)とは、グリニッジ天文台グリニッジ子午線(経度0度)における平均太陽時(mean solar time)を指す。イギリスの標準時(standard time)は伝統的にこの名で呼ばれる。ただし日本では平均時ではなくグリニッジ標準時グリニッジひょうじゅんじ)と訳されることが多い。

かつて国際的な基準時刻および世界各地域の標準時の基準はグリニッジ平均時であったが、現在は概念を修正した協定世界時 (UTC) へ変更されている。

※引用のため一部修正

グリニッジ標準時 - Wikipedia

ちなみに、GMTUTCは100年で18秒間のズレが生じるそうです。

このことから、求める式に瑕疵があれば正確に計算できないので注意が必要です。

VBAでのUNIX時間は以下のように求める

DateDiff("s", "1970/1/1 00:00:00", Now()) - 32400

最後に引き算を行っている「32400」という数字は、日本との時差(9時間)を秒数で算出するためである。
9 * 60 * 60 = 32400 (秒)

【JavaScript】多次元配列を作成する方法など。

こんにちは、なんだか簡単なところだと思っていたら、ハマったので備忘録です。

Google Apps Script で簡単なアプリを作っています。

言語はJavascriptをもとにしており、独自に定義されたメソッドを書いて使います。

getRangeとか、Gmail.search()といったものです。

そんななかで、要素を取り出すのにループを使いますが、これがハマりどころなんですね・・・。

用途によりけりですが、以下のように(1,3)行列を作ってみます。

    var arr = [];
    for ( var i = 0; i < 1; i++ ){
      arr[i] = [];
      arr[i][0] = "はろー";
      arr[i][1] = "こん";
      arr[i][2] = "ちわ";
    }
    for ( v in arr ) console.log(arr[v]);

こんな状況で、iに配列をしたりしていると無駄にたくさんできてしまうことがあります。

そんなときは「push」を使って、簡単に多次元配列が作れてしまいます。

    var container = [];
    var inner = ["はろー","こん","ちわ"];   

    contain.push(test);

    for( c in container ) console.log( container[c] );