![[PukiWiki]](image/pukiwiki.png "[PukiWiki]")
#author("2023-04-28T14:01:53+09:00","default:irrp","irrp") →ExcelのVBA #contents * ファイルダイアログ（オープン） [#f5041b4a] Dim dlg As FileDialog Set dlg = Application.FileDialog(msoFileDialogOpen) dlg.InitialFileName = "C:\Windows\" dlg.Show 'execute だと開く所までやってくれる Cells(1, 1) = dlg.SelectedItems(1) -[[[VBA]フォルダ選択ダイアログの使い方・使い分け>https://y-moride.com/vba/dailog-folder-picker.html]] 2021 -Win32APIを直叩きしたい場合 --https://www.moug.net/tech/acvba/0020007.html Public Declare Function GetOpenFileName _ Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" ( _ pOpenFileName As OPENFILENAME) As Long 'pOpenFileName構造体(ユーザー定義型)の宣言 Type OPENFILENAME lStructSize As Long '構造体のサイズ hwndOwner As Long 'ダイアログを所有 ' するウインドウハンドル hInstance As Long 'アプリケーションインスタンス lpstrFilter As String 'フィルタ lpstrCustomFilter As Long 'ユーザ定義フィルタ nMaxCustrFilter As Long 'ユーザ定義フィルタの ' バッファサイズ nFilterIndex As Long 'デフォルトフィルタのインデックス lpstrFile As String '選択されたファイル名 nMaxFile As Long 'ファイル名のバッファ lpstrFileTitle As String '選択されたファイル名のタイトル nMaxFileTitle As Long 'ファイル名のタイトルのバッファ lpstrInitialDir As String '初期ディレクトリ lpstrTitle As String 'ダイアログボックスのタイトル Flags As Long 'オプション nFileOffset As Integer 'ファイル名の最後の「\」までの ' オフセット値 nFileExtension As Integer '拡張子までのオフセット値 lpstrDefExt As String 'デフォルトの拡張子 lCustrData As Long 'OSがフック関数に渡すアプリ定義のデータ lpfnHook As Long 'メッセージを処理するフック関数 ' へのポインタ lpTemplateName As Long End Type '定数宣言 '複数のファイルを選択可能に Public Const OFN_ALLOWMULTISELECT = &H200 'ファイルが存在しなかった場合、新規作成するかどうか表示 Public Const OFN_CREATEPROMPT = &H2000 'エクスプローラ形式のダイアログを使用 Public Const OFN_EXPLORER = &H80000 '存在しないファイル名を入力不可に Public Const OFN_FILEMUSTEXIST = &H1000 '「読み取り専用」チェックボックスを非表示 Public Const OFN_HIDEREADONLY = &H4 'カレントディレクトリをダイアログのカレントディレクトリにする Public Const OFN_NOCHANGEDIR = &H8 Public Const OFN_NODEREFERENCELINKS = &H100000 'ネットワークコンピュータを非表示に Public Const OFN_NONETWORKBUTTON = &H20000 Public Const OFN_NOREADONLYRETURN = &H8000 Public Const OFN_NOVALIDATE = &H100 'ファイルが存在していた場合、上書きを問い合わせる Public Const OFN_OVERWRITEPROMPT = &H2 '有効なパス名のみを入力可能に Public Const OFN_PATHMUSTEXIST = &H800 '「読み取り専用」チェックボックスをオンにする Public Const OFN_READONLY = &H1 '「ヘルプ」ボタンの表示 Public Const OFN_SHOWHELP = &H10 '拡張子がデフォルトの拡張子と異なる場合に設定されるフラグ Public Const OFN_EXTENSIONDIFFERENT = &H400 Public Function GetFileName() As String Dim pOpenFileName As OPENFILENAME Dim lngRet As Long 'Accessアプリケーションのハンドルを取得 pOpenFileName.hwndOwner = Application.hWndAccessApp pOpenFileName.hInstance = 0 'ファイルフィルタの設定 pOpenFileName.lpstrFilter = "全てのファイル (*.*)" & _ String(1, vbNullChar) & _ "*.*" & _ String(2, vbNullChar) pOpenFileName.lpstrCustomFilter = 0 pOpenFileName.nMaxCustrFilter = 0 pOpenFileName.nFilterIndex = 1 pOpenFileName.lpstrFile = String(511, vbNullChar) pOpenFileName.nMaxFile = 511 pOpenFileName.lpstrFileTitle = String(512, vbNullChar) pOpenFileName.nMaxFileTitle = 511 pOpenFileName.lpstrInitialDir = String(1, vbNullChar) pOpenFileName.lpstrTitle = String(1, vbNullChar) pOpenFileName.nFileOffset = 0 pOpenFileName.nFileExtension = 0 pOpenFileName.lpstrDefExt = String(1, vbNullChar) pOpenFileName.lCustrData = 0 pOpenFileName.lpfnHook = 0 pOpenFileName.lpTemplateName = 0 pOpenFileName.lStructSize = Len(pOpenFileName) '読取専用ファイルを隠す pOpenFileName.Flags = OFN_HIDEREADONLY _ Or OFN_EXPLORER lngRet = GetOpenFileName(pOpenFileName) GetFileName = Left(pOpenFileName.lpstrFile, _ InStr(pOpenFileName.lpstrFile, vbNullChar) - 1) End Function *CSVをUTF-8で保存する [#l005b80d] -通常のSave機能ではUnicodeまでしか指定できないが、いくつか方法はある -フリーのモジュールを使用する方法 --http://www.vector.co.jp/soft/winnt/prog/se320375.html -ADODB.Streamを使う方法 Dim myFileName As String Dim myPath As String Dim NewFileName As String myFileName = ActiveWorkbook.name myPath = ActiveWorkbook.Path Dim outbook As Workbook Set outbook = ActiveWorkbook Dim sht As Worksheet Dim i As Integer For i = 1 To ActiveWorkbook.Worksheets.Count Windows(myFileName).Activate NewFileName = ActiveWorkbook.Worksheets(i).name Set sht = outbook.Worksheets(i) Dim StreamIn As Object Set StreamIn = CreateObject("ADODB.Stream") With StreamIn .Open .Charset = "shift_jis" .Type = 2 .Position = 0 End With Dim StreamOut As Object Set StreamOut = CreateObject("ADODB.Stream") With StreamOut .Open .Charset = "UTF-8" .Type = 2 .Position = 0 End With Dim row As Integer row = sht.UsedRange.Cells(sht.UsedRange.Count).row Dim line As Integer line = sht.UsedRange.Cells(sht.UsedRange.Count).Column Dim fileName As String fileName = myPath & "\" & NewFileName & ".dat" Dim r As Integer For r = 1 To row Dim l As Integer For l = 1 To line - 1 StreamIn.WriteText sht.Cells(r, l) & "," Next StreamIn.WriteText sht.Cells(r, line), 1 Next StreamIn.SetEOS StreamIn.Position = 0 StreamIn.CopyTo StreamOut StreamOut.SetEOS StreamOut.Position = 0 StreamOut.SaveToFile fileName, 2 StreamIn.Close StreamOut.Close Set StreamIn = Nothing Set StreamOut = Nothing Next i -[[エクセルVBAでBOM無しのUTF-8でCSVファイルなどを出力する方法>https://tonari-it.com/excel-vba-utf8n-bom/]] 2016
