【VBA】フォームにControlを動的に配置してクラスでイベントを受け取る

0

    <機能>

    ・フォームにControlをオーナードローします

     TextBox×20

     OptionButton×60(3個1組でグループ化)

     ConboBox×20

     Label×20

    ・フォームのプロパティをスクロールできるよう設定します

     ScrollBars(スクロールバーの表示)

     ScrollHeight(フォーム全体の高さ)

    ・クラス(WithEvents)でイベントを受け取ります

     Class1:OptionButtonクリックイベントのコールバック

     Class2:ComboBox選択変更イベントのコールバック

     

    <動作環境>

    Microsoft Office 2016

     

    <実行イメージ>

    フォームInitializeでコントロールを配置

    (テキスト、ラジオ、コンボ、ラベルを20組配置)

    VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,グループ化,
    イベントを受け取りテキストボックスに結果表示します

    VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,
     

    <使い方>

    フォームを追加します(ID:UserForm1)


     

    ラジオボタンイベント通知クラスを追加します(Class1)

    コンボボックスイベント通知クラスを追加します(Class2)

    フォーム表示用の標準モジュールを追加します(Module1)


    ソースを貼り付けます

    ユーザフォーム表示()を実行するとフォームを表示します

     

    Module1

    '/*********************************************

    '/ ユーザフォームを表示する
    '/*********************************************

    Public Sub ユーザフォーム表示()
        UserForm1.Show
    End Sub
     

    UserForm1

    '//フォームの幅
    Private Const D_FWIDTH = 400
    '//フォームの高さ
    Private Const D_FHEIGHT = 500
    '//配置するテキストボックスの幅
    Private Const D_WIDTH = 230
    '//配置するテキストボックスの高さ
    Private Const D_HEIGHT = 100
    '//配置するテキストボックスの間隔
    Private Const D_MARGIN = 10
    '//配置するコントロールグループの数
    Private Const D_CONTROLCNT = 20
    '//イベントを検知するクラス(OptionButton)
    Private cls1(1 To D_CONTROLCNT * 3) As New Class1
    '//イベントを検知するクラス(ComboBox)
    Private cls2(1 To D_CONTROLCNT) As New Class2

     

    '/*********************************************
    '/ フォームの初期化イベント
    '/ 動的にコントロールを配置する
    '/ ※コントロールの種類は
    DeveloperNetwork参照
    '/  テキストボックス
    '/  ラジオボタン(OptionButton)×3(グループ化)
    '/  コンボボックス
    '/  ラベル
    '/*********************************************

    Private Sub UserForm_Initialize()

     

        '//フォームのスクロール(垂直方向)有効
        UserForm1.ScrollBars = fmScrollBarsVertical
        '//フォームのスクロールを含めた高さ
        UserForm1.ScrollHeight = 20 + D_CONTROLCNT * (D_HEIGHT + D_MARGIN)
        '//コントロールを格納する
        Dim tmpOB As Control
        Dim tmpCB As Control
       
        For i = 1 To D_CONTROLCNT
            '//テキストボックスを追加
            With UserForm1.Controls.Add("Forms.TextBox.1")
                .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = 40
                .Width = D_WIDTH
                .Height = D_HEIGHT
                .MultiLine = True
            End With
           
            '//ラジオボタンを追加
            Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
            With tmpOB
                .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = D_WIDTH + 60
                .Width = 80
                .Height = 20
                .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 1)
                .GroupName = "OB" & CStr(i) '//グループ化する
                .Value = True
            End With
            cls1(((i - 1) * 3) + 1).initClass tmpOB, ((i - 1) * 3) + 1
           
            Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
            With tmpOB
                .Top = 40 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = D_WIDTH + 60
                .Width = 80
                .Height = 20
                .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 2)
                .GroupName = "OB" & CStr(i) '//グループ化する
                .Value = False
            End With
            cls1(((i - 1) * 3) + 2).initClass tmpOB, ((i - 1) * 3) + 2
           
            Set tmpOB = UserForm1.Controls.Add("Forms.OptionButton.1")
            With tmpOB
                .Top = 60 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = D_WIDTH + 60
                .Width = 80
                .Height = 20
                .Caption = "ラジオボタン" & CStr(((i - 1) * 3) + 3)
                .GroupName = "OB" & CStr(i) '//グループ化する
                .Value = False
            End With
            cls1(((i - 1) * 3) + 3).initClass tmpOB, ((i - 1) * 3) + 3
           
            '//コンボボックスを追加
            Set tmpCB = UserForm1.Controls.Add("Forms.ComboBox.1")
            With tmpCB
                .Top = 80 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = D_WIDTH + 60
                .Width = 80
                .Height = 20
                .List = Array("晴れ", "曇り", "雨")
                .ListIndex = 0
            End With
            cls2(i).initClass tmpCB, i
           
            '//ラベルを追加
            With UserForm1.Controls.Add("Forms.Label.1")
                .Top = 20 + (i - 1) * (D_HEIGHT + D_MARGIN)
                .Left = 5
                .Width = 30
                .Height = 20
                .Caption = "No." + CStr(i)
            End With
        Next
    End Sub

     

    Class1(OptionButton通知)

    '//イベントを受け取るコントロール

    Private WithEvents OB As MSForms.OptionButton
    '//コントロールのインデックスを格納
    Private idx As Integer
     
    '/*********************************************
    '/ ラジオボタン(OptionButton)をセット
    '/*********************************************

    Public Sub initClass(ByVal o As MSForms.OptionButton, ByVal i As Integer)
        Set OB = o
        idx = i
    End Sub
     
    '/*********************************************
    '/ ラジオボタン(OptionButton)クリックイベント
    '/*********************************************

    Private Sub OB_Click()
        Dim strControl As String
        Dim tmpText As Control
        Dim strText As String
       
        '//ユーザフォームのテキストボックスに出力
        strControl = OB.Name
        '//OptionButton1(idx=1)→TextBox1に出力
        '//OptionButton2(idx=2)→TextBox1に出力
        '//OptionButton3(idx=3)→TextBox1に出力
        '//OptionButtonN(idx=N)→TextBox{(idx-1)÷3の商+1}に出力

        Set tmpText = UserForm1.Controls("TextBox" & CStr(((idx - 1) ¥ 3) + 1))
        If tmpText.Value = "" Then
            strText = ""
        Else
            strText = tmpText.Value & vbCrLf
        End If
        strText = strText & "ラジオがクリックされました name=" & strControl
       
        tmpText.Value = strText
    End Sub
     
    Class2(ComboBox通知)
    '//イベントを受け取るコントロール
    Private WithEvents CB As MSForms.ComboBox
    '//コントロールのインデックスを格納
    Private idx As Integer
     
    '/*********************************************
    '/ コンボボックス(ComboBox)をセット
    '/*********************************************

    Public Sub initClass(ByVal c As MSForms.ComboBox, ByVal i As Integer)
        Set CB = c
        idx = i
    End Sub
     
    '/*********************************************
    '/ コンボボックス(ComboBox)選択偏向イベント
    '/*********************************************

    Private Sub CB_Change()
        Dim strControl As String
        Dim tmpText As Control
        Dim strText As String
       
        '//ユーザフォームのテキストボックスに出力
        strControl = CB.Name
        Set tmpText = UserForm1.Controls("TextBox" & CStr(idx))
        If tmpText.Value = "" Then
            strText = ""
        Else
            strText = tmpText.Value & vbCrLf
        End If
        strText = strText & "コンボが " & CB.Value & " に変更されました name=" & strControl
       
        tmpText.Value = strText
    End Sub
     
    よろしければポチッと押してください

     


    【VBA】位置を指定してバイナリファイルを読み書きする

    0

      <機能>

      ・テスト用のバイナリファイルを出力します

      ・位置を指定してファイルに書き込みを行います

      (Putステートメント)

      ・Seekで位置を指定してファイルから読み込みを行います

      (Getステートメント)

       

      <動作検証>

      Microsoft Office 2016

       

      <実行イメージ>

      指定位置(1062バイト目/1077バイト)から書き込みを実施

      全角8文字(16バイト)を書き込み

      Putステートメントでバイナリファイル書き込み(VBA)

      先頭から37バイト目から全角26文字を読み込み

      Seekで位置指定,Getステートメントでバイナリファイル読み込み(VBA)

       

      <使い方>

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

      バイナリファイルを読み書き() を実行すると処理を開始します

       

      '********************************************
      'ファイルポインタ(位置)を指定してファイルを読み書き
      '********************************************

      Sub バイナリファイルを読み書き()
          Dim strFile As String
          Dim fp As Long, fileLen As Long
          Dim strbuf As String * 26
         
          '//ファイル名を生成
          strFile = ThisWorkbook.Path & "¥binaryTest.dat"
         
          '//テスト用バイナリデータをファイルへ書き込み
          Call TestFileWrite(strFile)
         
          '//バイナリモードでファイルをオープン
          fp = FreeFile
          Open strFile For Binary As #fp
          '//ファイルサイズを取得
          fileLen = LOF(fp)
          '//最後の8文字(16バイト)にデータを書き込み
          '//第2引数には先頭から書き込む場合は1を指定する

          Put #fp, (fileLen - 16) + 1, "さいごの8バイト"
         
          '//読み込み位置にポインタ移動
          Seek #fp, 37
          '//26文字[ABCDEFGHIJKLMNOPQRSTUVWXYZ]読込
          Get #fp, , strbuf
          Debug.Print strbuf
         
          '//ファイルを閉じる
          Close (fp)
          MsgBox "おわりました", vbInformation
      End Sub
      '********************************************
      'バイナリデータをテストファイルに出力
      '********************************************

      Sub TestFileWrite(ByVal strfil As String)
          '//バイナリファイルの1バイト毎の入出力にはByte型を用いる
          Dim strbuf As String * 1024
          Dim i As Integer
          Dim fp As Long
          '//書き込みデータをセット
          strbuf = "abcdefghijklmnopqrstuvwxyz0123456789" & _
                      "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & _
                      "0123456789月火水木金土日あいうえおかきくけこ"
          '//FreeFile関数で使用可能なファイル番号を割り当て
          fp = FreeFile
          '//ファイルが存在する場合は指定アドレスが上書きされるだけのため
          '//書き込み前にファイルを削除するか中身を一旦クリアする

          Open strfil For Output As #fp
          Close (fp)
          '//ファイルオープン(バイナリ書き込みでオープン、ファイルが存在しない場合は新規作成)
          '//モードに下記のいずれかが指定されていればファイルが存在しない場合、新規作成されます
          '//追加モード(Append)、バイナリモード(Binary)、出力モード(Output)、ランダムアクセスモード(Random)

          Open strfil For Binary Access Write As #fp
          '//ファイルに書き込み(ファイル先頭からの書き込みを明示)
          Put #fp, 1, strbuf
         
          '//ファイルを閉じる
          Close (fp)
      End Sub
       
      よろしければポチッと押してください

      【VBA】フォルダ選択ダイアログを表示する

      0

        <機能>

        フォルダ選択ダイアログを表示します。

        下記プロパティを設定します。

        ・初期表示フォルダ

        ・ダイアログタイトル

        ・ボタンのキャプション

         

        <動作検証>
        Microsoft Office 2016

         

        <実行イメージ>

        VBA,フォルダ選択ダイアログイメージ

        VBA,選択フォルダ表示

         

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

        フォルダを選択する() を実行すると処理を開始します

         

        '/********************************************************
        '/* フォルダ選択ダイアログを表示する
        '/* 引数:
        '/*  strDefault 初期表示フォルダ
        '/* 戻り値:
        '/*  選択されたときtrue、キャンセルされたときfalse
        '/*  strSelect  選択されたフォルダパス(参照)
        '/********************************************************

        Function SelectFolder(ByVal strDefault As String, _
                            ByRef strSelect As String) As Boolean
            SelectFolder = False
            strSelect = ""
            
            '//フォルダ選択ダイアログを表示
            With Application.FileDialog(msoFileDialogFolderPicker)
                '初期表示フォルダ
                .InitialFileName = strDefault & "¥"
                'タイトルを指定
                .Title = "フォルダ選択ダイアログサンプル"
                'ボタンのキャプションを変更
                .ButtonName = "選択確定"
                
                'フォルダが選択された
                If .Show = True Then
                    strSelect = .SelectedItems(1)
                    SelectFolder = True
                Else
                    .Execute
                End If
            End With
        End Function


        '/********************************************************
        '/* フォルダ選択ダイアログ呼び出しサンプル
        '/********************************************************

        Public Sub フォルダを選択する()
            Dim strSelect As String
            Dim wksel As Variant, wkmsg As String
            
            '//フォルダを選択する
            If Not SelectFolder(ThisWorkbook.Path, strSelect) Then
                MsgBox "フォルダ選択がキャンセルされました", vbCritical
                Exit Sub
            End If
            
            '//選択されたフォルダを表示
            MsgBox "選択フォルダ:" & vbCrLf & strSelect, vbInformation
            
        End Sub
         

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

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

         


        【VBA】ファイル選択ダイアログ(単一・複数ファイル)

        0

          <機能>

          (1)単一ファイル選択ダイアログを表示

          (2)複数ファイル選択ダイアログを表示

           

          <動作検証>
          Microsoft Office 2016

           

          <実行イメージ>

          設定は

          ・ダイアログタイトル

          ・単一ファイル/複数ファイル選択

          ・ファイルフィルター(txtまたはcsv)

          ・初期表示フォルダ

          (エクセルブックと同じフォルダを指定)

          ファイル選択ダイアログイメージ

          複数ファイル選択結果を表示したところ

          複数ファイル選択結果

           

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

          ファイルを選択する() を実行すると処理を開始します

           

          '/********************************************************
          '/* ファイル選択ダイアログ(単一/複数ファイル選択)を表示する
          '/* 引数:
          '/*  strDefault 初期表示フォルダ
          '/*  isMulti    trueのとき複数ファイル選択可能
          '/* 戻り値:
          '/*  選択されたときtrue、キャンセルされたときfalse
          '/*  strSelect  選択されたファイルフルパス(参照)
          '/********************************************************

          Function SelectFile(ByVal strDefault As String, _
                              ByVal isMulti As Boolean, _
                              ByRef strSelect() As String) As Boolean
              Dim sItem As Variant
              SelectFile = False
              ReDim strSelect(0)
              strSelect(0) = ""
              
              '//ファイル選択ダイアログを表示
              '//DialogTypeは以下の通りです(
          詳細はMSDN参照)
              '//msoFileDialogFilePicker ファイルの参照
              '//msoFileDialogFolderPicker フォルダの参照
              '//msoFileDialogOpen ファイルを開く
              '//msoFileDialogSaveAs 名前を付けて保存

              With Application.FileDialog(msoFileDialogFilePicker)
                  '複数選択不可(単一/複数ファイル選択)
                  .AllowMultiSelect = isMulti
                  '初期表示フォルダ
                  .InitialFileName = strDefault & "¥"
                  'ファイルフィルター(txt/csvフィルターを一番上に表示)
                  .Filters.Add "テキストファイル", "*.txt;*.csv", 1
                  'エクセルファイル選択のとき
                  '.Filters.Add "MSエクセルファイル", "*.xls*", 1
                  'タイトルを指定
                  .Title = "ファイル選択ダイアログサンプル"
                  
                  'ファイルが選択された
                  If .Show = True Then
                      For Each sItem In .SelectedItems
                          If strSelect(0) <> "" Then
                              '配列を拡張
                              ReDim Preserve strSelect(UBound(strSelect) + 1)
                          End If
                          strSelect(UBound(strSelect)) = sItem
                          SelectFile = True
                      Next sItem
                  Else
                      .Execute
                  End If
              End With
          End Function


          '/********************************************************
          '/* ファイル選択ダイアログ呼び出しサンプル
          '/********************************************************

          Public Sub ファイルを選択する()
              Dim strSelect() As String
              Dim wksel As Variant, wkmsg As String
              
              '//(1)単一ファイルを選択する
              If Not SelectFile(ThisWorkbook.Path, False, strSelect()) Then
                  MsgBox "ファイル選択がキャンセルされました", vbCritical
                  GoTo multiselect
              End If
              
              '//選択された単一ファイルを表示
              MsgBox "選択ファイル:" & vbCrLf & strSelect(0), vbInformation
              
          multiselect:
              
              '//(2)複数ファイルを選択する
              If Not SelectFile(ThisWorkbook.Path, True, strSelect()) Then
                  MsgBox "ファイル選択がキャンセルされました", vbCritical
                  Exit Sub
              End If
              
              '//選択された複数ファイルを表示
              wkmsg = ""
              For Each wksel In strSelect
                  wkmsg = wkmsg & vbCrLf & wksel
              Next wksel
              MsgBox "選択ファイル:" & wkmsg, vbInformation
          End Sub
           

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

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

           

           


          【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
             

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

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

             



            | 1/6PAGES | >>

            calendar

            S M T W T F S
            1234567
            891011121314
            15161718192021
            22232425262728
            293031    
            << July 2018 >>

            profile

            others

            mobile

            qrcode         スマホ表示に戻す