【VBA】セルを塗りつぶしてCODE39バーコードを作成してみる

0

    <機能>

    (1)セルを使ってバーコード(CODE39規格)を作成します

     ※チェックディジットを付加します

    (2)バーコード作成データは設定ファイルから読み込みます

    (3)設定ファイルをデモ用に自動生成します

    (4)セルを使って作成したバーコードをファイルに出力します

     ※画像保存がうまくいかない場合はデバッグモードでブレイクするとうまくいくことが多いです

     (原因調査中)

     

    <動作検証>

    Microsoft Office 2016

     

    <実行イメージ>

    セルを使ってバーコード(CODE39)を作成

    VBA,CODE39バーコードを作成

    画像(JPG)として出力します

    VBA,CODE39バーコードを画像出力

     

    <補足>

    CODE39のパターン定義は以下のように行いました

    ・合計9個の文字で塗りとスペースを表現

     (例)「A」だと 100001001

    ・塗りとスペースは交互に出現(CODE39規格)

    ・太いバーを1、細いバーを0で表現する

    ・対象文字は「1-0,A-Z,-.$/+%」と半角スペースと「*」

     

    セルにバーコードを描画するルールを以下のように行いました

    ・細エレメント幅は1セル分
    ・太エレメント幅は2セル分(エレメント比=2.0)

     ※9本のうち、3本は太線なので1文字12セルとなります
    ・キャラクタギャップは1セル分
    ・クワイエットゾーン(左右余白)は1文字分+αで15セル

    ・チェックディジットを付加

     

    <使い方>
    適当なところにソースを貼り付けてください
    Code39バーコード作成() を実行すると処理を開始します

     

    '//バーコードの高さ
    Const D_BARHEIGHT As Integer = 25
    '//バーコードの上余白
    Const D_BARMARGIN_UP As Integer = 10
    '//バーコードの下余白
    Const D_BARMARGIN_DOWN As Integer = 50
    '//バーコードの左余白(出力位置)
    Const D_BARMARGIN_LEFT As Integer = 100

     

    '/********************************************************
    '/* Code39バーコード作成
    '/********************************************************

    Sub Code39バーコード作成()
        Dim strCode() As String
        Dim strDemotxt As String
        Dim folPath As String
        
        '//デモ用キャラクタ設定ファイルを自動生成
        strDemotxt = ThisWorkbook.Path & "¥バーコード変換対象.txt"
        MakeSampleTxt strDemotxt
        
        '//デモ用キャラクタ設定ファイルから変換対象キャラクタを取得
        ReadSampleTxt strDemotxt, strCode
           
        '//先頭にシートを追加
        strday = Now
        ThisWorkbook.Worksheets.Add Before:=Worksheets(1)
        Sheets(1).Name = "Code39_" & Format(strday, "yyyymmddhhmmss")
        
        '//全て(数式、文字列、書式、コメント、アウトライン)クリア
        Cells.Select
        Selection.Clear
        Selection.Font.Name = "MS ゴシック"
        Selection.Font.Size = 30
        Selection.ColumnWidth = 0.5
        Selection.RowHeight = 6
        Range("A1").Select
        With ActiveWindow
            '//ズーム設定
            .Zoom = 40
            '//枠線を非表示
            .DisplayGridlines = False
        End With
        
        '//画像保存用ディレクトリを作成
        folPath = ThisWorkbook.Path & "¥" & Sheets(1).Name
        MkDir folPath
        If Dir(folPath, vbDirectory) = "" Then
            MsgBox "画像保存フォルダの作成に失敗しました" & vbCrLf & folPath, vbCritical
            Exit Sub
        End If
        
        '//バーコード作成メイン処理
        MakeCode39BarCode strCode, folPath
           
        '//印刷の向き(横:xlLandscape 縦:xlPortrait)
        ActiveSheet.PageSetup.Orientation = xlPortrait
        Range("A1").Select
           
        '//終了メッセージ
        MsgBox "おわりました", vbInformation

    End Sub

     

    '/********************************************************
    '/* Code39バーコード作成 メイン処理
    '/********************************************************

    Sub MakeCode39BarCode(ByRef strCode() As String, ByVal folPath As String)
        
        Dim i As Integer, j As Integer, k As Integer
        Dim strptn As String, chk As String, strmoji As String
        Dim gyo As Long
        Dim clm As Integer
        Dim wkmoji As String
        
        '//初回の上余白を設定
        gyo = D_BARMARGIN_UP
        For i = 0 To UBound(strCode)
            
            '//描画ルール
            '//(1)細エレメント幅は1セル分
            '//(2)太エレメント幅は2セル分(エレメント比=2.0)
            '//(3)キャラクタギャップは1セル分
            '//(4)クワイエットゾーン(左右余白)は1文字分+αで15セル

            clm = D_BARMARGIN_LEFT
            '//クワイエットゾーン分あける
            clm = clm + 15
            
            '//チェックディジットを取得
            chk = GetCheckDigit(strCode(i))
            If chk = "" Then
                MsgBox "チェックディジットの取得に失敗しました" & vbCrLf & strCode(i), vbCritical
                GoTo nextrec
            End If
            
            '//スタートコード・ストップコード、チェックディジットを付加
            strmoji = "*" & strCode(i) & chk & "*"
            For j = 1 To Len(strmoji)
                '//パターンを取得
                strptn = GetCode39BarCodePattern(Mid(strmoji, j, 1))
                If strptn = "" Then
                    MsgBox "バーコードのパターンが見つかりませんでした" & vbCrLf & strCode(i), vbCritical
                    Cells(gyo, clm) = "【Error!!】"
                    GoTo nextrec
                End If
                
                '//描画開始
                For k = 1 To 9
                    wkmoji = Mid(strptn, k, 1)
                    If 1 = (k Mod 2) Then
                        '//奇数の時はバー(塗り部分)
                        Range(Cells(gyo, clm), Cells(gyo + D_BARHEIGHT, clm + CInt(wkmoji))).Interior.Color = RGB(0, 0, 0)
                    Else
                        '//偶数の時はスペース(空白)
                    End If
                    
                    '//カラム位置を進める
                    clm = clm + (1 + CInt(wkmoji))
                Next
                '//最終文字でなければキャラクタギャップを入れる
                If j <> Len(strmoji) Then
                    clm = clm + 1
                End If
                
            Next
            '//クワイエットゾーン分あける
            clm = clm + 15
            '//データを表示
            With Range(Cells(gyo + D_BARHEIGHT, D_BARMARGIN_LEFT), Cells(gyo + D_BARHEIGHT + 8, clm - 1))
                .Merge
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                '//マイナス(-)、スラッシュ(/)が含まれる場合の文字化け防止
                .NumberFormatLocal = "@"
                .Value = strCode(i)
            End With
            
            '//画像として保存
            Dim savePath As String
            Dim rg As Range, cht As ChartObject
            savePath = folPath & "¥img" & Format(CStr(i + 1), "0000") & ".jpg"
            
            Range(Cells(gyo, D_BARMARGIN_LEFT), Cells(gyo + D_BARHEIGHT + 8, clm - 1)).Select
            Set rg = Selection
            rg.CopyPicture appearance:=xlScreen, Format:=xlBitmap
            
            Set cht = ActiveSheet.ChartObjects.Add(rg.Left, rg.Top, rg.Width, rg.Height)
            cht.Activate
            cht.Chart.Paste
            
            cht.Parent.Activate
            ActiveChart.ChartArea.Format.Line.Visible = False
            ActiveChart.HasLegend = False
            cht.Chart.Export Filename:=savePath, Filtername:="JPG"
            cht.Chart.Parent.Delete
            Range("A" & CStr(gyo)).Select
                   
            '//行の開始位置を更新(バーコードの高さ+データ表示)
            gyo = gyo + D_BARHEIGHT + 8
            '//下余白を設定
            gyo = gyo + D_BARMARGIN_DOWN
            '//改ページ(水平方向)を設定
            ActiveSheet.HPageBreaks.Add Before:=Range("A" & CStr(gyo))
            
            '//次のバーコードの上余白を確保
            gyo = gyo + D_BARMARGIN_UP
            
    nextrec:
        Next

     

    End Sub

     

    '/********************************************************
    '/* Code39バーコード作成 指定文字のパターンを取得
    '/********************************************************

    Function GetCode39BarCodePattern(ByVal moji As String) As String
        GetCode39BarCodePattern = ""
        Dim ptn As Variant
        Dim i As Integer, wkstr() As String
        
        '//Code39のパターン定義
        '//(1)バー(塗り部分)とスペース(空白)の合計は9
        '//(2)バーとスペースが交互に出現する
        '//(3)太:1、細:0で表現する
        '//(4)対象文字「1-0,A-Z,-.$/+%」、半角スペース、*

        ptn = Array("0,000110100", "1,100100001", "2,001100001", _
                    "3,101100000", "4,000110001", "5,100110000", _
                    "6,001110000", "7,000100101", "8,100100100", _
                    "9,001100100", "A,100001001", "B,001001001", _
                    "C,101001000", "D,000011001", "E,100011000", _
                    "F,001011000", "G,000001101", "H,100001100", _
                    "I,001001100", "J,000011100", "K,100000011", _
                    "L,001000011", "M,101000010", "N,000010011", _
                    "O,100010010", "P,001010010", "Q,000000111", _
                    "R,100000110", "S,001000110", "T,000010110", _
                    "U,110000001", "V,011000001", "W,111000000", _
                    "X,010010001", "Y,110010000", "Z,011010000", _
                    "-,010000101", ".,110000100", " ,011000100", _
                    "$,010101000", "/,010100010", "+,010001010", _
                    "%,000101010", "*,010010100")
        
        '//パターンを検索
        For i = 0 To UBound(ptn)
            wkstr = Split(ptn(i), ",")
            If moji = wkstr(0) Then
                If UBound(wkstr) = 0 Then Exit Function
                GetCode39BarCodePattern = wkstr(1)
                Exit Function
            End If
        Next
        
    End Function

     

    '/********************************************************
    '/* Code39バーコード作成 チェックディジットを取得
    '/********************************************************

    Function GetCheckDigit(ByVal str As String)
        GetCheckDigit = ""
        Dim i As Integer
        Dim wkmoji As String, iwk As Integer, ichk As Integer
        Dim total As Integer
        
        total = 0
        For i = 1 To Len(str)
            wkmoji = Mid(str, i, 1)
            iwk = Asc(wkmoji)
            
            If iwk >= 48 And iwk <= 57 Then
                '//数値はそのまま足す
                total = total + (iwk - 48)
            
            ElseIf iwk >= 65 And iwk <= 90 Then
                '//A-Zは10-35に変換して足す
                total = total + (iwk - 55)
            
            Else
                '//特殊記号
                Select Case iwk
                Case 45 '"-"
                    total = total + 36
                Case 46 '"."
                    total = total + 37
                Case 32 '半角スペース
                    total = total + 38
                Case 36 '"$"
                    total = total + 39
                Case 47 '"/"
                    total = total + 40
                Case 43 '"+"
                    total = total + 41
                Case 37 '"%"
                    total = total + 42
                Case Else
                    Exit Function
                End Select
                
            End If
        Next
        
        '//モジュラス43方式なので43で割った余りを求める
        ichk = total Mod 43
        
        '//チェックディジットを取得
        If ichk >= 0 And ichk <= 9 Then
            GetCheckDigit = CStr(ichk)
        ElseIf ichk >= 10 And ichk <= 35 Then
            GetCheckDigit = Chr(65 + (ichk - 10))
        Else
            '//特殊記号
            Select Case ichk
            Case 36
                GetCheckDigit = "-"
            Case 37
                GetCheckDigit = "."
            Case 38
                GetCheckDigit = " "
            Case 39
                GetCheckDigit = "$"
            Case 40
                GetCheckDigit = "/"
            Case 41
                GetCheckDigit = "+"
            Case 42
                GetCheckDigit = "%"
            Case Else
                Exit Function
            End Select
        End If
        
    End Function

     

    '/********************************************************
    '/* 取得文字列がCode39対象文字かチェック
    '/* 戻り値;True(対象) False(非対象文字が混入)
    '/********************************************************

    Function isCode39Character(ByVal buf As String) As Boolean
        Const strchk As String = "[0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ.$/+% ,-]"
        Dim i As Integer, moji As String
        
        '//本サンプルプログラムの仕様として32文字を上限とする
        If LenB(buf) > 32 Then
            isCode39Character = False
            Exit Function
        End If
        
        isCode39Character = True
        For i = 1 To Len(buf)
            moji = Mid(buf, i, 1)
            If moji Like strchk Then
                'パターンにマッチ
            Else
                'パターンにアンマッチ
                isCode39Character = False
                Exit Function
            End If
        Next
    End Function

     

    '/********************************************************
    '/* デモ用ファイルからバーコード変換対象キャラクタを取得
    '/********************************************************

    Sub ReadSampleTxt(ByVal strSample As String, ByRef strCode() As String)
        Dim fl As Long
        
        '//取得バッファを初期化
        ReDim strCode(0)
        strCode(0) = ""
        
        '//テスト用サンプルテキストファイルをオープン
        fl = FreeFile
        Open strSample For Input As #fl
        
        Do Until EOF(fl)
            Line Input #fl, buf
            '//大文字に変換
            buf = UCase(buf)
            '//半角に変換
            buf = StrConv(buf, vbNarrow)
            
            '//空白行、"'"で始まる行はスキップ
            If buf = "" Then GoTo nextgyo
            If Mid(buf, 1, 1) = "'" Then GoTo nextgyo
            
            '//対象文字列意外が設定されていればスキップ
            If Not isCode39Character(buf) Then GoTo nextgyo
            
            '//バーコード変換対象文字列としてバッファにセット
            If strCode(0) = "" Then
                strCode(0) = buf
            Else
                ReDim Preserve strCode(UBound(strCode) + 1)
                strCode(UBound(strCode)) = buf
            End If
    nextgyo:
        Loop
        
        '//テスト用サンプルテキストファイルをクローズ
        Close #fl
    End Sub

     

    '/********************************************************
    '/* バーコード変換対象キャラクタ設定ファイルをダミーで作成
    '/********************************************************

    Sub MakeSampleTxt(ByVal strSample As String)
        Dim fl As Long
        
        '//テスト用サンプルテキストファイルをオープン
        fl = FreeFile
        Open strSample For Output As #fl
        
        '//データを書き込み
        Print #fl, "'//// テスト用ダミーテキストファイル"
        Print #fl, "1234567890"
        Print #fl, "123456"
        Print #fl, "123"
        Print #fl, "abcdefghijklmnopqrstuvwxyz"
        Print #fl, "ABC-12345/DEF"
        Print #fl, "-.$/+ %"
        
        '//テスト用サンプルテキストファイルをクローズ
        Close #fl
    End Sub
     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     


    【VBA】オリジナルプログレスバーを実装する

    0

      <機能>

      (1)オリジナル(独自)のプログレスバーを作成します

       ※ActiveXのプログレスバーは使用しません

      (2)フレームの中に背景が緑のラベルを配置してWidth変更により進捗表示します

      (3)透明ラベルにて進捗「999 / 999 %」を表示します

      (4)キャンセル(中断)押下により処理を中断できます

       

      <動作検証&開発環境>
      Microsoft Office2016

       

      <実行イメージ>

      ユーザフォーム表示直後のイメージ

      プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

      窪んだフレーム中の緑のラベルのWidthを変化させます

      進捗表示ラベルは背景を透明に設定しています

      プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

      キャンセル押下により中断できます

      [X]ボタンや[Alt]+[F4]でも同じ動作をします

      プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

       

      <使い方>
      (1)[挿入]メニューからユーザフォームを挿入します
      ※名前はUserForm1(デフォルト名)とします

      プログレスバー,独自,オリジナル,ラベル,幅,UserForm,常に前面,キャンセル,

      (2)コントロールを配置します

      ・Frame1

       Caption : なし

       Width : 400

       SpecialEffect : fmSpecialEffectSunken(窪みフレーム)

      ・Label1

       BackColor : 緑(なんでもいいです)

       Caption : なし

       Width : 400(フレームの中に配置)

      ・Label2

       BackStyle : mBackStyleTransparent(背景透明)

       TextAlign : fmTextAlignCenter(中央揃え)

      ・CommandButton1

       Caption : スタート

      ・CommandButton2

       Caption : キャンセル

       

      (3)ソースをUserForm1に貼り付けます

       

      '//Windows API
      Private Declare Function GetForegroundWindow Lib "user32" () As Long
      Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
      Private Const HWND_TOPMOST As Long = -1
      Private Const SWP_NOSIZE As Long = &H1&
      Private Const SWP_NOMOVE As Long = &H2&

       

      '//キャンセルボタン押下判定フラグ
      Public bCancel As Boolean
      '//プログレスバー実行中フラグ
      Public bProgress As Boolean

       

      '/********************************************************
      '/* ユーザフォームを常に前面に表示
      '/********************************************************

      Private Sub UserForm_Activate()
          Call SetWindowPos(GetForegroundWindow, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
      End Sub

       

      '/********************************************************
      '/* ユーザフォームの初期化
      '/********************************************************

      Private Sub UserForm_Initialize()
          
          '//ラベルの位置を明示的に指定
          '//フレーム(Frame1)とラベル(Label1)の左上座標&幅を合わせる

          With Me.Label1
              .Left = 0
              .Top = 0
              .Width = 400
              .Visible = False
          End With
          
          '//ラベル2(プログレスバーの進捗表示用)初期表示
          Me.Label2.Caption = "スタートボタンを押してください"
          '//キャンセルボタン押下フラグ
          bCancel = False
          '//プログレスバー実行中フラグ
          bProgress = False
      End Sub

       

      '/********************************************************
      '/* [スタート]押下によりプログレスバー開始
      '/********************************************************

      Private Sub CommandButton1_Click()
          Dim iBar As Integer
          Dim strMsg As String
          
          '//初期値セット
          iBar = 0
          bCancel = False
          strMsg = "おわりました"
          '//プログレスバー(ラベル)は最初は幅0
          Me.Label1.Width = 0
          Me.Label1.Visible = True
          '//ラベル2(プログレスバーの進捗表示用)は0を初期表示
          Me.Label2.Caption = "  0 / 100 %"
          
          '//プログレスバー開始
          bProgress = True
          Do
              '0-100まで
              If iBar = 100 Then Exit Do
              
              '200ミリ秒ごとにカウントアップ
              '大括弧[]で囲むとSleepを使わなくてもミリ秒指定が可能です
              'Application.Wait Now + TimeValue("0:00:01")

              Application.Wait [Now() + "0:00:00.2"]
              iBar = iBar + 1
              
              'ラベルの幅を400としているのでカウンター×4とする
              Me.Label1.Width = (iBar * 4)
              '進捗表示(分子はスペース埋めで3桁固定とする)
              Me.Label2.Caption = Format(CStr(iBar), "@@@") & " / 100 %"
              '再描画
              Me.Repaint
              
              'キャンセルボタン押下等のイベント処理
              DoEvents
              If bCancel Then
                  If MsgBox("キャンセルしてもよろしいですか?", vbQuestion + vbYesNo) = vbYes Then
                      'メッセージで[はい]が押下されたらキャンセルする
                      strMsg = "キャンセルされました"
                      Exit Do
                  Else
                      'メッセージで[いいえ]が押下されたらキャンセル処理をスキップ
                      bCancel = False
                  End If
              End If
          Loop
          
          '//プログレスバー終了
          bProgress = False
          '//終了メッセージ表示
          MsgBox strMsg, vbInformation
          
      End Sub

       

      '/********************************************************
      '/* [キャンセル]押下イベントハンドラ
      '/********************************************************

      Private Sub CommandButton2_Click()
          '//キャンセル処理へ進む
          bCancel = True
      End Sub

       

      '/********************************************************
      '/* 「x」ボタンでフォームを閉じないようにする
      '/********************************************************

      Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
          '//プログレスバー実行中に「x」またはAlt+F4でフォームを閉じようとしたとき
          If bProgress Then
              If CloseMode = vbFormControlMenu Then
                  '//キャンセル処理へ進む
                  bCancel = True
                  '//閉じるボタン「x」では閉じない
                  Cancel = True
              End If
          End If
      End Sub
       

       

      よろしければポチッと押してください

      プログラマー ブログランキングへ

       


      【VBA】シートをPDFで出力する(ExportAsFixedFormat使用)

      0

        <機能>

        (1)ExportAsFixedFormatを使用してシートをPDFで出力します

         ※ExportAsFixedFormatの対象はOffice 2013以降です

         ※マクロ実行時に必ずブックをマクロ有効形式(.xlsm)で保存してください

        (2)サンプルの出力対象シートを自動で生成します

         ※コピペのみで動作確認できます

        (3)印刷範囲、ヘッダー、フッターも自動で設定します

         

        <動作検証&開発環境>
        Microsoft Office2016

         

        <実行イメージ>

        サンプルの出力対象シートを自動で生成

        VBA,PDF,ExportAsFixedFormat,印刷範囲,PDF変換,PDF出力,

        ExportAsFixedFormatを使用してシートをPDFで出力

        VBA,PDF,ExportAsFixedFormat,印刷範囲,PDF変換,PDF出力,

         

        <使い方>

        適当なところにソースを貼り付けてください

        実行前にブックをマクロ有効形式(.xlsm)で保存してください

        (400、1004などの実行エラーとなります)

        PDF出力メイン() を実行すると処理を開始します

         

        '********************************************
        'シートをPDFで出力するサンプルプログラム
        '(1)出力対象のサンプル明細書を自動生成
        '(2)印刷範囲、ヘッダー、フッターを設定
        '(3)PDFファイルを出力
        '※ExportAsFixedFormatの対象:Office 2013 and later
        '********************************************

        Public Sub PDF出力メイン()
            '//描画を停止
            Application.ScreenUpdating = False
            
            '//(1)出力対象のサンプル明細書を自動生成
            サンプル明細書作成
            
            '//(2)印刷範囲、ヘッダー、フッターを設定
            '//PageSetupメンバーの詳細については Office DevCenter を参照

            With ActiveSheet.PageSetup
                '印刷の向き(横:xlLandscape 縦:xlPortrait)
                .Orientation = xlLandscape
                
                '横1ページ×縦1ページ
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1
                
                'ヘッダーを設定
                '詳細は ヘッダーとフッターに指定できる書式コード 参照
                '日付と現在時刻

                .RightHeader = "印刷日時:&D(&T)"
                
                'フッターを設定
                'ページ番号

                .CenterFooter = "&P/&N"
                'ブック名とシート名
                .RightFooter = "&F(&A)"
                
                '余白設定
                '上3、左1.5、右1.5、下2、ヘッダー2、フッター1

                .TopMargin = Application.CentimetersToPoints(3)
                .LeftMargin = Application.CentimetersToPoints(1.5)
                .RightMargin = Application.CentimetersToPoints(1.5)
                .BottomMargin = Application.CentimetersToPoints(2)
                .HeaderMargin = Application.CentimetersToPoints(2)
                .FooterMargin = Application.CentimetersToPoints(1)
                
                '水平方向ページ中央
                .CenterHorizontally = True
            End With
            
            '//改ページプレビュー表示
            ActiveWindow.View = xlPageBreakPreview
            '//ズーム100%で表示
            ActiveWindow.Zoom = 100
            
            '//(3)PDFファイルを出力
            '//ファイル名にF4セルの氏名をセット(スペースはトリムする)

            Dim strPdf As String
            strPdf = ThisWorkbook.Path & "¥Meisai_" & Replace(Replace(Range("F4").Text, " ", ""), " ", "") & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".pdf"
            
            '//PDFに変換する
            '//ExportAsFixedFormatメソッドの詳細については Office DevCenter を参照

            ThisWorkbook.Sheets(ThisWorkbook.ActiveSheet.Index).ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPdf, Quality:=xlQualityStandard
            
            '//描画を再開
            Application.ScreenUpdating = True
        End Sub


        '********************************************
        'PDF出力対象のサンプル明細書を生成
        '(1)サンプルデータをセット
        '(2)帳票の体裁を自動で設定
        '********************************************

        Public Sub サンプル明細書作成()
            Dim ar As Variant
            ar = Array( _
            "経費明細書,,,,,,,,", _
            "サンプル株式会社 総務部,,,,,,,,", _
            "〒000-0000 東京都新宿区西新宿1丁目,,,,,,,,", _
            "電話,(03)9999-9999,,氏名,山田 太郎,,,,", _
            "FAX,(03)9999-9998,,部署,営業部,,,,", _
            "電子メール,info@abcdef.com,,職位,管理責任者,,,,", _
            "Web,www.abcdef.com,,上司,鈴木 イチロウ,,,,", _
            ",,,,,,,,", _
            "日付,勘定科目,内容,宿泊費,交通費,食費,通信費,雑費,合計", _
            "43070,営業経費,旅費,44500,22500,2000,,500,69500", _
            "43085,営業経費,営業会議,,13500,,,,13500", _
            "43092,営業経費,営業会議,,13500,,1600,,15100", _
            "合計,,,44500,49500,2000,1600,500,98100")

            '//シートをクリア
            ThisWorkbook.Activate
            Cells.Select
            Selection.Clear
            Selection.ColumnWidth = 20
            Selection.RowHeight = 25
            Selection.Font.Name = "メイリオ"
            Selection.Font.Size = 11
            Selection.Borders.LineStyle = False
            
            '//セルの折り返しを解除
            Selection.WrapText = False
            '//列幅調整
            Columns("A").ColumnWidth = 3
            '//帳票タイトル調整
            With Rows("1")
                .RowHeight = 40
                .VerticalAlignment = xlTop
                .Font.Size = 25
                .Font.Bold = True
            End With
            
           '//データをシートに展開
            Dim i As Integer, j As Integer
            Dim wkbuf As Variant
            
            For i = 0 To UBound(ar)
                wkbuf = Split(ar(i), ",")
                '不正なデータであれば次レコードへ
                If UBound(wkbuf) <> 8 Then GoTo nextrec
                'データを表示
                For j = 0 To UBound(wkbuf)
                    '表示はB列からのため(j + 1)とする
                    Cells(i + 1, (j + 1) + 1) = wkbuf(j)
                Next j
            
        nextrec:
            Next i
            
            '//セルにインデントを設定
            With Range("C4:C7,F4:F7")
                .IndentLevel = 1
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeLeft).Weight = xlThin
            End With
            '//表に罫線を引く
            With Range("B9:J13")
                .Borders.LineStyle = xlContinuous
                .Borders.Weight = xlThin
            End With

            '//項目行を中央揃えにする
            With Range("B9:J9")
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Interior.Color = RGB(128, 128, 128)
                .Font.Color = RGB(255, 255, 255)
            End With
            
            '//合計行の設定
            With Range("B13:J13")
                .Interior.Color = RGB(217, 217, 217)
                .Font.Bold = True
            End With
            With Range("B13")
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
            '//金額書式設定(円マーク付き、カンマ区切り)
            Range("E10:J13").NumberFormatLocal = "¥#,##0; ¥-#,##0"
            '//日付書式設定(YYYY年MM月DD日形式)
            With Range("B10:B12")
                .NumberFormatLocal = "yyyy""年""mm""月""dd""日"""
                .HorizontalAlignment = xlCenter
            End With
            Range("A1").Select
        End Sub

         

        よろしければポチッと押してください

        プログラマー ブログランキングへ


        【VBA】独自のメニューバー/右クリックメニューを設定する

        0

          <機能>

          (1)独自のメニューバー(コマンドバー)を設定します

           [アドイン](メニュー)

            [備忘録サンプル](オリジナル)  

             緑でフォームを表示

             ピンクでフォームを表示

          (2)コマンドバーはワークブックオープンで生成、クローズで破棄されます

          (3)独自の右クリックメニュー(セル右クリックメニュー)を設定します

          (4)下記メニュー機能を実装します

           緑でフォームを表示(MainShow1プロシージャコール)

           ピンクでフォームを表示(MainShow2プロシージャコール)

          (5)フォームの表示位置を保持します

           

          <動作検証&開発環境>
          Microsoft Office2016

           

          <実行イメージ>

          アドインメニューに独自メニューを設定します

          CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,コマンドバー削除

          セルを右クリックすると独自メニューが表示されます

          CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,,コマンドバー削除

          [緑でフォームを表示]をクリックするとMainShow1がコールされます

          ユーザフォーム,背景色,CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

          [ピンクでフォームを表示]をクリックするとMainShow2がコールされます

          ユーザフォーム,背景色,CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

           

          <使い方>

          (1)[挿入]メニューからユーザフォームを挿入します

          ※名前はUserForm1(デフォルト名)とします

          CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

          (2)[挿入]メニューから標準モジュールを挿入します

          ※名前はModule1(デフォルト名)とします

          CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

          (3)ユーザフォーム(UserForm1)にボタンコントロールを貼り付けます

          ※名前はbtnClose、キャプションを「閉じる」とします

          CommandBars,msoControlButton,Controls.Add,オリジナルメニュー,独自メニュー,

           

          (4)ソースを貼り付けます

           

          ’ThisWorkbook(OpenとBeforeCloseイベント処理追加)

          '/********************************************************
          '/* ワークブックオープンでメニューバーを作成
          '/********************************************************

          Private Sub Workbook_Open()
              Dim wkstr As String
              
              'メニューバーの作成
              Call Module1.CreateMenu
              'ポップアップメニューの作成
              Call Module1.CreatePopUp
              
              'フォームの初期表示位置はエクセルアプリケーションの左上
              Module1.XPOS = Application.Left
              Module1.YPOS = Application.Top
              
              '先頭シートのA1選択
              ThisWorkbook.Sheets(1).Select
              Range("A1").Select
          End Sub

           

          '/********************************************************
          '/* ワークブッククローズでメニューバーを削除
          '/********************************************************

          Private Sub Workbook_BeforeClose(Cancel As Boolean)
              Dim objCB As CommandBar
              
              Set objCB = Application.CommandBars("Worksheet Menu Bar")

              'メニューバーが作成済みであれば削除する
              On Error Resume Next
              objCB.Controls(Module1.CAP_MAIN).Delete
              
              objCB = Nothing
          End Sub

           

          ’Module1(定数定義と独自メニュー生成処理を追加)

          '//フォームの表示位置を保持
          Public XPOS As Integer
          Public YPOS As Integer

          Public Const CAP_MAIN = "備忘録サンプル"
          Public Const MENU1 = "緑でフォームを表示"
          Public Const MENU2 = "ピンクでフォームを表示"


          '/********************************************************
          '/* メニューバー(アドインメニュー)の作成
          '/********************************************************

          Public Sub CreateMenu()
              Dim objCB As CommandBar
              Dim CmdCtrl As CommandBarControl
              Dim CmdBtn1 As CommandBarButton, CmdBtn2 As CommandBarButton
              
              Set objCB = Application.CommandBars("Worksheet Menu Bar")

              '作成済みであれば削除
              On Error Resume Next
              objCB.Controls(CAP_MAIN).Delete
              On Error GoTo 0
              
              Set CmdCtrl = CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup, Temporary:=True)
              CmdCtrl.Caption = CAP_MAIN
              
              Set CmdBtn1 = CmdCtrl.Controls.Add(Type:=msoControlButton)
              CmdBtn1.Caption = MENU1
              CmdBtn1.OnAction = "MainShow1"
              
              Set CmdBtn2 = CmdCtrl.Controls.Add(Type:=msoControlButton)
              CmdBtn2.Caption = MENU2
              CmdBtn2.OnAction = "MainShow2"
          End Sub

           

          '/********************************************************
          '/* ポップアップメニュー(右クリックメニュー)の作成
          '/********************************************************

          Public Sub CreatePopUp()
              Dim CmdBar As CommandBar
              Dim CmdBtn1 As CommandBarButton, CmdBtn2 As CommandBarButton
              
              Set CmdBar = CommandBars("Cell")
              CmdBar.Reset
              Set CmdBtn1 = CmdBar.Controls.Add(msoControlButton, Temporary:=True)
              CmdBtn1.BeginGroup = True
              CmdBtn1.Caption = MENU1
              CmdBtn1.OnAction = "MainShow1"
                 
              Set CmdBtn2 = CmdBar.Controls.Add(msoControlButton, Temporary:=True)
              CmdBtn2.BeginGroup = True
              CmdBtn2.Caption = MENU2
              CmdBtn2.OnAction = "MainShow2"
                 
              Set CmdBar = Nothing
              Set CmdBtn1 = Nothing
              Set CmdBtn2 = Nothing
          End Sub

           

          '/********************************************************
          '/* メニュー画面の表示
          '/* MENU1からコールされた場合はMainShow1
          '/* MENU2からコールされた場合はMainShow2
          '/********************************************************

          Public Sub MainShow1()
              'フォームのキャプション変更
              UserForm1.Caption = Module1.MENU1
              'メニュー画面の背景色を設定
              UserForm1.BackColor = RGB(169, 208, 142)
              UserForm1.btnClose.BackColor = RGB(169, 208, 142)
              'メニュー画面表示
              UserForm1.Show vbModal
          End Sub

           

          Public Sub MainShow2()
              'フォームのキャプション変更
              UserForm1.Caption = Module1.MENU2
              'メニュー画面の背景色を設定
              UserForm1.BackColor = RGB(255, 178, 255)
              UserForm1.btnClose.BackColor = RGB(255, 178, 255)
              'メニュー画面表示
              UserForm1.Show vbModal
          End Sub

           

          'UserForm1(表示位置の設定、Clickイベント)

          '/********************************************************
          '/* フォームの表示位置を指定
          '/********************************************************

          Private Sub UserForm_Activate()
              Application.ScreenUpdating = False
              Me.Left = Module1.XPOS
              Me.Top = Module1.YPOS
              Application.ScreenUpdating = True
          End Sub

           

          '/********************************************************
          '/* [閉じる]ボタン押下時の処理
          '/********************************************************

          Private Sub btnClose_Click()
              Unload Me
          End Sub

           

          '/********************************************************
          '/* フォームを閉じるときの処理
          '/********************************************************

          Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
              Module1.XPOS = Me.Left
              Module1.YPOS = Me.Top
              
              '[x]ボタンで閉じれなくする
              If CloseMode = vbFormControlMenu Then
                  Cancel = True
              End If
          End Sub
           

          よろしければポチッと押してください

          プログラマー ブログランキングへ


          【VBA】ドキュメントプロパティを設定する

          0

            <機能>

            ブックのドキュメントプロパティ(BuiltinDocumentProperties)を設定します

            (1)新規ブックにドキュメントプロパティをセット

            (2)先頭シートにドキュメントプロパティの内容を出力します

             

            <動作検証&開発環境>

            Microsoft Office2016

             

            <実行イメージ>

            シートにドキュメントプロパティの内容を出力

            VBA,BuiltinDocumentProperties,プロパティ設定,タイトル,件名,タグ,分類項目,コメント,作成者,改定番号,バージョン番号,会社,マネージャー,コンテンツの作成日時,

            VBA,BuiltinDocumentProperties,プロパティ設定,タイトル,件名,タグ,分類項目,コメント,作成者,改定番号,バージョン番号,会社,マネージャー,コンテンツの作成日時,

             

            <使い方>

            適当なところにソースを貼り付けてください

            新規ブックにプロパティを設定する() を実行すると処理を開始します

             

            '********************************************
            'VBAで新規ブックにプロパティを設定する
            '(1)ブックを新規作成
            '(2)プロパティを設定
            '(3)シートにプロパティの内容を出力して保存
            '********************************************

            Sub 新規ブックにプロパティを設定する()
                Dim strName As String
                Dim gyo As Integer

             

                '//ブック名を生成
                strName = ThisWorkbook.Path & "¥SAMPLE_" & Replace(Replace(Replace(Now(), "/", ""), " ", ""), ":", "") & ".xlsx"

             

                '//テスト用ブックを新規作成
                '//FileFormatにExcelブック(*.xlsx)形式を指定
                Workbooks.Add

             

                '//ブックを保存する(ファイル形式に.xlsx:xlOpenXMLWorkbookを指定)
                '//XlFileFormat列挙体の設定値についてはOffice DevCenter参照

                ActiveWorkbook.SaveAs Filename:=strName, FileFormat:=xlOpenXMLWorkbook
                ActiveWorkbook.Close

             

                '//ブックにプロパティを設定
                Workbooks.Open strName
                With Workbooks(Mid(strName, InStrRev(strName, "¥") + 1))
                    'タイトル
                    .BuiltinDocumentProperties("Title").Value = "ブックにプロパティをセット"
                    '件名
                    .BuiltinDocumentProperties("Subject").Value = "プロパティの設定と取得のテスト"
                    'タグ
                    .BuiltinDocumentProperties("Keywords").Value = "VBA BuiltinDocumentProperties"
                    '分類項目
                    .BuiltinDocumentProperties("Category").Value = "VBAプログラムサンプル"
                    'コメント
                    .BuiltinDocumentProperties("Comments").Value = "平成28年12月会議にて使用予定" & vbCrLf & "佐藤部長レビュー済み資料(2016.11.05)"
                    '作成者
                    .BuiltinDocumentProperties("Author").Value = "山田 太郎"
                    '改定番号(整数)
                    .BuiltinDocumentProperties("Revision Number").Value = "4"
                    'バージョン番号
                    .BuiltinDocumentProperties("Document version").Value = "1.0.8"
                    '会社
                    .BuiltinDocumentProperties("Company").Value = "株式会社○△□"
                    'マネージャー
                    .BuiltinDocumentProperties("Manager").Value = "田中部長"
                    'コンテンツの作成日時
                    .BuiltinDocumentProperties("Creation Date").Value = "2016/12/20 10:09"

             

                    '//すべてのプロパティを先頭シートに出力する
                    .Sheets(1).Activate

             

                    '//セル幅、フォントを指定
                    Columns("A:B").Select
                    Selection.Clear
                    Selection.ColumnWidth = 30
                    Selection.RowHeight = 50
                    Selection.Font.Name = "メイリオ"
                    Selection.Font.Size = 10
                    '//折り返して全体を表示
                    Selection.WrapText = True
                    '//水平方向左、垂直方向中央揃え
                    Selection.HorizontalAlignment = xlLeft
                    Selection.VerticalAlignment = xlCenter
                    Range("A1").Select

             

                    '//エラー処理ルーチンを有効
                    On Error Resume Next
                    gyo = 1
                    For Each p In .BuiltinDocumentProperties
                        Cells(gyo, 1).Value = p.Name
                        Cells(gyo, 2).Value = p.Value
                        gyo = gyo + 1
                    Next
                    On Error GoTo 0

             

                    '//ブックをクローズ
                    .Close True
                End With
            End Sub
             

            よろしければポチッと押してください

            プログラマー ブログランキングへ

             



            << | 2/6PAGES | >>

            calendar

            S M T W T F S
               1234
            567891011
            12131415161718
            19202122232425
            262728293031 
            << August 2018 >>

            profile

            others

            mobile

            qrcode         スマホ表示に戻す