may the VBA be with you

Excel VBAとか業務自動化とか

思いつき連載　VBA王子 ニューヨークへ行く　#10

思いつき連載

前回

vba-belle-equipe.hatenablog.com

登場人物

赤羽健太

主人公

王子友哉

赤羽の同期。営業のエース候補。

川口瑞穂

赤羽の同期。広報課。

浮間船子

赤羽の先輩。

  • 甘いものが好き
  • 辛いものも好き
  • 食べ物は大体好き
北浦和人

おかっぱ頭。

#10

「大丈夫だったかなあ」赤羽は自席に着く間際、そうつぶやいていた。
　北浦のおかっぱ頭と蕨係長の吊り上がって見える眼鏡を並べて、思い浮かべる。
「まあ、大丈夫か」
　特に理由は思い当たらなかったが、そう言って終わらせることにした。
　それよりも、やることがある。
　自分用の共有フォルダに入っているテキストファイルを開き、地下で習った作業を復習しなければならない。
　Excelを起動。開発タブを表示。VBEを表示。標準モジュールの追加・・・。
「名前をtestにして、msgboxを・・・」
　腕を組み、モニターをしばらく睨みつけた後、キーをぽんと押す。小さく、メッセージの枠が表示された。
「で、できた・・・」
「なおったの？」
　赤羽が感慨に浸る間もなく、斜め後ろから声がかけられる。声の主は確認するまでもなく、浮間だ。
「いや、まだです。てゆうか、ようやくスタート地点ですよ。自分のExcelでもVBAを書けるってことがわかりました」
「ふーん。よくわからないけど」浮間は口をもごもご動かしながら、ディスプレイをずいっと覗く。
　ほのかにアーモンドの臭いを感じ、赤羽は青酸カリを連想した。
　が、そのことについて特に何も言わなかった。
「『こんにちは』って言ってるよ？」
「はい。僕が表示させたんですよ」
　浮間が意味わからないという視線を送り、赤羽は、どやという視線を送った。
「返事するとどうなんの？」
「・・・どうもなりませんよ」
　なんだ、と浮間は左の頬だけを上げて笑った。「つまんないの」
　赤羽は多少残念に思いながら、気を取り直して次のミッションに移った。
　北浦とのやり取りを思い出す。
「このファイルをまずお前が確認してから、オッケーだったら浮間に渡せ」
「あ、もうなおしてくれたんですか」
「あー、まあ、そういうことでいい」
「そういうことでいいとは？」
「うー、まあ、別に今の段階でお前が知る必要はないが、知りたくば教えてやろう」
「・・・結構です」
「いいか、あの女がどこもいじってないのにおかしくなったって言っていたら、それはどこかしらいじってるってことだ」
「結構ですって言ったのに」
「だから、元ファイルを渡せば大体解決する。ただ、そうでない場合もあるから、まずはお前の環境で確認しろ。ここの端末だとつながってないから」
　はいはい、と回想の北浦に返事しつつ、赤羽はExcelファイルを開いた。

　広報課第一係長の蕨は、入社当初から、女性であるということよりも頭の回転、話す速さ、歩く速さで注目された。現在では「社内で一番仕事ができる」という評価を確固たるものとし、女性初の部長はもちろん、さらに上も狙える存在とみなされている。
　北浦は入社当初から誰が好き好んでやるのだろうというそのおかっぱ頭で注目され、現在では「そういえばあの人最近みないね」という評価を確固たるものとしている。　
　資料管理室で、２人は久々に向かい合っていた。
「どう？　そろそろやる気になった？」
　蕨が口を開く。何気ない質問も、彼女が口にすれば攻撃となる。
　北浦は辟易すると同時に懐かしくも思っていた。
「何が」
「システムの統合？　それとも、連携システムの構築だっけ」
　蕨がペンをコツコツと机に当てる。
「そんな余裕はない」
「時間はあったでしょう。そろそろやることやれば？」
　北浦は大きく息をついた。
「資料の電子化は大変な作業なんです。暇な部署だと思われるのは心外です」
「わかっています。でもあなたのことだから、PDF化する仕組みを何かしら作っているんでしょう？　誰でもできるように」
　北浦は目をそらした。
「ひょっとしたら、OCRを使って全文検索できるように、とか考えてる？　もしくはもうできちゃった？」
　北浦は顔をしかめた。そして、おずおずと口を開いた。
「前から言おうと思ってたんだけどさ」
「何？」
「眼鏡、似合ってるな」



- つづく -


次

vba-belle-equipe.hatenablog.com

Excelでドット絵作成ツールを作る　その5

VBAサンプル

はじめに

前回、

vba-belle-equipe.hatenablog.com

泣き言を言って終わりました。

現状報告

f:id:vba-belle-equipe:20160506175022p:plain

こんな感じです。


うまくいっていなかった以下の点を修正してみました。

左側に変な白い部分ができる

グラフを先に作成していて、それがCopyPicture の際に見切れていたため。*1
CopyPictureの後にグラフを作るようにしました。

貼り付けがうまくいかず、真っ白になる

試行錯誤の末、「cht.Parent.Select」を入れることで安定したような気がしなくもない感じです。


コード

現時点でのコードは

'///シートモジュール///

Option Explicit

Private Sub Worksheet_Change(ByVal target As Range)
  Call junbi '共通変数セット
  If target.Address = TateAddress Or target.Address = YokoAddress Then
    Call setCamvas      'キャンバスセット
    Exit Sub
  End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal target As Range)
 ' Debug.Print target.Address
  
  '選択範囲多すぎる場合何もしない
  If target.Count > 1000 Then
    Exit Sub
  End If
  
  Call junbi '共通変数セット
  '//描画色選択//
  Dim lngNewColor As Long
  
  '(カラーピッカー)
  If target.Address = DrawColorAddress Then
    lngNewColor = GetColorDlg
    Call changeDrawColor(lngNewColor)
    Exit Sub
  End If
  
  '(選択履歴)
  If target.Count = 1 And _
    Not Application.Intersect(target, Range(RirekiAddress)) Is Nothing Then
    lngNewColor = target.Interior.Color
    Call changeDrawColor(lngNewColor)
    Exit Sub
  End If
  
  Call drawCells(target)  '描画
  
End Sub



'///標準モジュール///

Option Explicit

Public Const DrawColorAddress As String = "$B$4:$B$5"
Public Const RirekiAddress As String = "$D$1:$D$35"
Public Const TateAddress As String = "$B$15"
Public Const YokoAddress As String = "$B$18"
Public Const CamvasBaseAddress As String = "$F$1"

Public BaseRng As Range
Public CamvasRng As Range
Public Tate As Long, Yoko As Long

Sub junbi()
  '手動モードなら何もしない
  If Range("A1") = "手動モード" Then
    End
  End If
  
  '共通変数をセット
  Set BaseRng = Range(CamvasBaseAddress)
  Tate = Range("B15")
  Yoko = Range("B18")
  Set CamvasRng = Range(BaseRng, Cells(BaseRng.Row + Tate + 1, _
                          BaseRng.Column + Yoko + 1))
End Sub

'描画色変更
Sub changeDrawColor(lngNewColor As Long)
  Dim i As Long
  If Range(DrawColorAddress).Interior.Color = lngNewColor Then
    Exit Sub
  End If
  Range(DrawColorAddress).Interior.Color = lngNewColor
  Range("A1").Select
  '色選択履歴
  Dim fnd As Boolean
  fnd = False
  For i = 1 To 35
    If Cells(i, 4).Interior.Color = lngNewColor Then
      fnd = True
      Exit For
    End If
  Next
  If fnd Then Exit Sub  '新しい色が履歴にある場合何もしない
  For i = 35 To 2 Step -1
    Cells(i, 4).Interior.Color = Cells(i - 1, 4).Interior.Color
  Next
  Cells(1, 4).Interior.Color = lngNewColor
End Sub

'キャンバス
Sub setCamvas()
  Dim r As Range
  Application.ScreenUpdating = False
  Cells.Interior.Pattern = xlSolid
  For Each r In CamvasRng
    If r.Row = BaseRng.Row Or r.Row = BaseRng.Row + Tate + 1 Or _
       r.Column = BaseRng.Column Or r.Column = BaseRng.Column + Yoko + 1 Then
       r.Interior.Pattern = xlGrid
    End If
  Next
  Application.ScreenUpdating = True
End Sub

'描画
Sub drawCells(target As Range)
  Dim r As Range
  Dim copyRng As Range
  Dim minCol As Long, maxCol As Long
  Dim minRow As Long, maxRow As Long
  Dim clr1 As Long  '描画色
  clr1 = Range(DrawColorAddress).Interior.Color
  minCol = BaseRng.Column + 1
  maxCol = BaseRng.Column + Yoko
  minRow = BaseRng.Row + 1
  maxRow = BaseRng.Row + Tate
  Set copyRng = Sheets("ドット絵作成").Range _
      (Cells(minRow, minCol), Cells(maxRow, maxCol))
  
  For Each r In target
    If minCol <= r.Column And r.Column <= maxCol And _
        minRow <= r.Row And r.Row <= maxRow Then
     ' Debug.Print r.Address
      r.Interior.Color = clr1
    End If
  Next
End Sub


'///標準モジュール（色選択）///

Option Explicit

Private Type ChooseColor
  lStructSize As Long
  hWndOwner As Long
  hInstance As Long
  rgbResult As Long
  lpCustColors As String
  flags As Long
  lCustData As Long
  lpfnHook As Long
  lpTemplateName As String
End Type

Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" _
                                      (pChoosecolor As ChooseColor) As Long

Private Const CC_RGBINIT = &H1                '色のデフォルト値を設定
Private Const CC_LFULLOPEN = &H2              '色の作成を行う部分を表示
Private Const CC_PREVENTFULLOPEN = &H4        '色の作成ボタンを無効にする
Private Const CC_SHOWHELP = &H8               'ヘルプボタンを表示

Public Function GetColorDlg() As Long
'機能 ： 色の設定ダイアログを表示し、そこで選択された色のRGB値を返す
'引数 ： lngDefColor デフォルト表示する色
'返値 ： 成功時 RGB値   キャンセル時-1  エラー時 -2  （ゼロは黒なので注意）

  Dim udtChooseColor As ChooseColor
  Dim lngRet As Long
  Dim lngDefColor As Long
  lngDefColor = Range(DrawColorAddress).Interior.Color

  With udtChooseColor
    'ダイアログの設定
    .lStructSize = Len(udtChooseColor)
    .lpCustColors = String$(64, Chr$(0))
    .flags = CC_RGBINIT + CC_LFULLOPEN
    .rgbResult = lngDefColor
    'ダイアログを表示
    lngRet = ChooseColor(udtChooseColor)
    'ダイアログからの返り値をチェック
    If lngRet <> 0 Then
      If .rgbResult > RGB(255, 255, 255) Then
        'エラー
        GetColorDlg = -2
      Else
        '正常終了、RGB値を返り値にセット
        GetColorDlg = .rgbResult
      End If
    Else
      'キャンセルが押されたとき
      GetColorDlg = -1
    End If

  End With

End Function


'///標準モジュール（画像出力）///

Option Explicit

Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Ext As String   '拡張子

'ファイル保存ダイアログ
Function getSaveFileName() As String
  Dim fPath As String
  Dim strExt As String
  strExt = Ext & "ファイル, *." & LCase(Ext) & ", 全てのファイル,*.*"
  fPath = Application.GetSaveAsFilename(fileFilter:=strExt)
  If fPath = "False" Then
    getSaveFileName = ""
  Else
    getSaveFileName = fPath
  End If
End Function

'画像出力
Sub imgOut()
  Dim rg As Range
  Dim cht As Chart
  Dim fName As String
  Ext = Range("A23")

  '保存ファイル名を取得
  fName = getSaveFileName
  If fName <> "" Then
    '出力範囲をセット
    Set BaseRng = Range(CamvasBaseAddress)
    Tate = Range("B15")
    Yoko = Range("B18")
    Set rg = Range(BaseRng.Offset(1, 1), Cells(BaseRng.Row + Tate, _
                            BaseRng.Column + Yoko))
    Application.ScreenUpdating = False
    rg.CopyPicture appearance:=xlScreen, Format:=xlPicture
    'チャートを追加して画像貼り付け
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
    cht.Parent.Select
    cht.Paste
    cht.Export Filename:=fName, filtername:=Ext
    cht.Parent.Delete
    Application.ScreenUpdating = True
  End If
End Sub

こんな感じです。

修正以外に

  • 各種画像拡張子に対応
  • 色選択履歴がダブらないように変更

あたりを実装しています。

*1:アホすぎる

5月4日はスター・ウォーズの日

映画

MAY THE FORCE BE WITH YOU!

というわけで、5月4日はスター・ウォーズの日です。

スター・ウォーズ ダース・ベイダー危機一発

「どれから観たらいい？」と訊かれると、自分は

４→５→６→１→２→３→４→５→６

と答えます。*1

*1:７は？

Life Is Strange 面白い

ゲーム

個人事業主にゴールデンウィークなんて関係ないといいつつだらけてるシリーズ第１弾。

最近お気に入りのゲームです。こればっかりやってます。


Steam：Life Is Strange™


主人公が時間を戻せる能力に目覚める系*1のストーリーなのですが、すごくよくできていて引き込まれます。

ちなみにPS3およびPS4で普通に日本語版が売られてるらしいんですが、英語版がやりたくてわざわざStreamでダウンロードしました。*2


英語版にしたくなったのは

こちらの動画の影響です。


日本語版を知らないでいうのもなんですが、英語版の雰囲気はとてもよいです。

半分以上何言ってるかわかりませんけどね。*3

*1:そんな系があるのかわかりませんが

*2:回線の調子が悪くて、10ギガバイトで24時間以上かかりました

*3:ちなみに、Stream版でも日本語にできます