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

<機能>

・フォームに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)

VBA,Class,WithEvents,Controls,OptionButton,TextBox,ComboBox,ユーザーフォーム追加,
 

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

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

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

VBA,Class,WithEvents,Controls,OptionButton,標準モジュール,クラスモジュール,
ソースを貼り付けます

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

 

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
           

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

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

           



          << | 2/7PAGES | >>

          selected entries

          categories

          calendar

          S M T W T F S
              123
          45678910
          11121314151617
          18192021222324
          25262728293031
          << August 2019 >>

          profile

          others

          archives