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

<機能>

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

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

・初期表示フォルダ

・ダイアログタイトル

・ボタンのキャプション

 

<動作検証>
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
         

         

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

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

         


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

        0

          <機能>

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

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

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

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

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

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

           

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

           

          <実行イメージ>

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

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

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

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

           

          <使い方>

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

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

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

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

           

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

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

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

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

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

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

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

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


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

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

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

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

           

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

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



          << | 2/6PAGES | >>