【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
           

           

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

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

           


          【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 | >>