【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
           

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

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

           


          【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
             

             

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

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

             



            | 1/5PAGES | >>

            calendar

            S M T W T F S
                 12
            3456789
            10111213141516
            17181920212223
            24252627282930
            31      
            << December 2017 >>

            profile

            others

            mobile

            qrcode