|
Vitamin Excel 窓の影(Windows情報) 
Ｅｘｃｅｌ銀行振込データ作成 (V2.30 UPD 07/11/11)
銀行カレンダー関数のExcelアドイン
ＭｄｂＣｍｐｔ(V2.05) |
Ｅｘｃｅｌ
ＶＢＡに効く Vitamin E
|
| Excel振込のソースコードの一部を公開（全銀データ項目の関連付け） | ||
| 読者のご要望にお応えし、Excel振込の全銀データ項目の関連付け部分のコードを公開します。一部APIを使用していますが、ほとんどExcelの機能を使っています。高度なことはやっていませんが参考にしてください。 | ||
| Option Explicit 'フルパス名からファイル名を取得 Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer 'ファイルが存在するか Private Declare Function PathFileExists Lib "SHLWAPI.DLL" Alias "PathFileExistsA" (ByVal pszPath As String) As Long 'pszPath[in]：ファイル名 'Return ：存在すれば 1、存在しなければ 0 がかえる。 '（注）SDKでは \\ serverのように Universal Naming Convention (UNC)を指定すると 0 がかえると記述があるが、正常に動作する。 Const 選択項目Max = 17 Const c全銀データ項目Max = 8 Const cPrgName = "関連付けサンプル" Dim 選択項目(1, 1 To 選択項目Max) As String Dim preText1 As String Private Sub CommandButton1_Click() '読込ﾌｧｲﾙ参照ボタンクリック時 Dim DefDir As String Dim fileSaveName Dim wTextBox As String 'ファイル読込ダイアログの初期フォルダ表示のため 'ドライブとフォルダを設定 wTextBox = Me!TextBox1.Value If Trim$(wTextBox) = "" Then DefDir = ThisWorkbook.Path Else DefDir = LsGetPath(wTextBox, "") End If On Error Resume Next ChDrive DefDir ChDir DefDir If Err Then ChDrive ThisWorkbook.Path ChDir ThisWorkbook.Path Err.Clear End If On Error GoTo 0 'ファイル読込ダイアログ fileSaveName = Application.GetOpenFileName( _ FileFilter:="Excelﾌｧｲﾙ(*.xls),*.xls,CSVﾌｧｲﾙ(*.CSV),*.CSV,ﾃｷｽﾄﾌｧｲﾙ(*.TXT),*.TXT,全てのﾌｧｲﾙ(*.*),*.*", _ FilterIndex:=1, Title:="変換するExcelまたはCSVﾌｧｲﾙを選択して下さい") If fileSaveName <> False Then Me!TextBox1.Value = fileSaveName XlsSheetToCombo fileSaveName Me!TextBox2.Value = 0 Me!TextBox3.Value = 1 Me!TextBox4.Value = 0 ScrollBar1MaxSet End If End Sub Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) 'ｼｰﾄ名コンボボックス、ダブルクリック時 Dim i As Integer, wList As String, k As String i = Me!ListBox1.ListIndex wList = Trim$(Me!ListBox1.List(i, 0)) With Me!ScrollBar1 If Len(Trim$(wList)) > c全銀データ項目Max And Mid$(wList, c全銀データ項目Max, 2) = " [" And _ Right$(wList, 1) = "]" Then Me!ListBox1.List(i, 0) = Left$(wList, c全銀データ項目Max) ElseIf .Min <= .Value And .Value <= .Max Then If Val(Me!TextBox2.Value) > 0 Then k = ActiveSheet.Cells(Val(Me!TextBox2.Value), .Value) Me!ListBox1.List(i, 0) = Left$(wList & String$(c全銀データ項目Max, " "), c全銀データ項目Max) & _ "[" & ColConv(str$(.Value)) & " " & k & "]" End If End With End Sub Private Function ColConv(ByVal v As String) As String 'カラム取り出し Dim c As String, i As Integer v = Trim$(v) If IsNumeric(v) Then c = ActiveSheet.Cells(1, Val(v)).Address() i = InStr(2, c, "$") ColConv = Mid(c, 2, i - 2) Else c = ActiveSheet.Range(v & "1").Address(ReferenceStyle:=xlR1C1) i = InStr(2, c, "C") ColConv = Mid$(c, i + 1) End If End Function Private Sub ComboBox1_Click() 'ｼｰﾄ名コンボボックス、クリック時 On Error Resume Next ActiveSheet.Cells(1, 1).Select ActiveWorkbook.Worksheets(Me!ComboBox1.Text).Activate ActiveSheet.Cells(1, 1).Select ScrollBar1MaxSet End Sub Private Sub ListBox1Set() '全銀データ項目の関連付けリストボックス設定 Dim i As Integer, j As Integer With Me!ListBox1 . Clear For i = 1 To 選択項目Max If 選択項目(1, i) = "" Then . AddItem . List(j, 0) = 選択項目(0, i) . List(j, 1) = str$(i) j = j + 1 End If Next i End With End Sub Function XlsSheetToCombo(ByVal XlsName As String, Optional NoMsg As Boolean = False) As Boolean 'シート名取り出し Dim i As Integer, w As String On Error Resume Next Me!ComboBox1.Clear Err.Clear XlsName = Trim$(XlsName) If PathFileExists(XlsName) = 1 Then With Application . Workbooks.Open FileName:=XlsName, ReadOnly:=True For i = 1 To .ActiveWorkbook.Worksheets.Count Me!ComboBox1.AddItem .ActiveWorkbook.Worksheets(i).Name Next i XlsSheetToCombo = True If Err Then w = XlsName & "のシート名取り出しに失敗しました。" Else If NoMsg = False Then MsgBox "リストからシート名を指定してください。", vbInformation, cPrgName Me!ComboBox1.ListIndex = 0 Me!ComboBox1.SetFocus End If End If End With Else w = "ﾌｧｲﾙの指定が違います。ﾌｧｲﾙが見つかりません。" End If i = True If Me!ScrollBar1.Value Then Me!ScrollBar1.Value = 1 With Me !ComboBox1.Enabled = i !TextBox2.Enabled = i !TextBox3.Enabled = i !TextBox4.Enabled = i !CommandButton3.Enabled = i !CommandButton4.Enabled = i !Frame1.Enabled = i End With End Function Private Sub ScrollBar1_Change() '横スクロールバーチェンジ時 On Error Resume Next ActiveSheet.Columns(Me!ScrollBar1.Value).Select End Sub Private Sub ScrollBar2_Change() '縦スクロールバーチェンジ時 Dim i As Integer Dim w As String w = ActiveCell.Address() w = Mid$(w, 2) i = InStr(w, "$") If i > 0 Then w = Left$(w, i - 1) Range(w & Val(Me!ScrollBar2.Value)).Select End Sub Private Sub TextBox1_Enter() '読込ﾌｧｲﾙ名記録 preText1 = Me!TextBox1.Value End Sub Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean) '読込ﾌｧｲﾙ存在チェック Dim w As String w = Trim$(Me!TextBox1.Value) If w > "" Then If PathFileExists(w) = 0 Then MsgBox "読込ﾌｧｲﾙが存在しません。" & Error, vbCritical, cPrgName ElseIf Me!TextBox1.Value <> preText1 Then XlsSheetToCombo Me!TextBox1.Value End If End If End Sub Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean) '見出し行の行数入力チェック If Not IsNumeric(Me!TextBox2.Value) Then MsgBox "行数を入力してください。", vbCritical, cPrgName Cancel = True Else Me!TextBox3.Value = Me!TextBox2.Value + 1 ScrollBar1MaxSet End If End Sub Private Sub ScrollBar1MaxSet() 'スクロールバー最大値とスクロール量設定 Me!ScrollBar1.Max = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column Me!ScrollBar1.LargeChange = Me!ScrollBar1.Max \ 10 + 1 Me!ScrollBar2.Max = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row Me!ScrollBar2.LargeChange = Me!ScrollBar2.Max \ 10 + 1 End Sub Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'データ開始行の行数入力チェック If Not IsNumeric(Me!TextBox3.Value) Then MsgBox "行数を入力してください。", vbCritical, cPrgName Cancel = True ElseIf Val(Me!TextBox3.Value) <= Val(Me!TextBox2.Value) Then MsgBox "データ行は見出し行より大きくしてください。", vbCritical, cPrgName Me!TextBox3.Value = Me!TextBox2.Value + 1 End If End Sub Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean) 'データ終了行の行数入力チェック If Not IsNumeric(Me!TextBox4.Value) Then MsgBox "行数を入力してください。", vbCritical, cPrgName Me!TextBox4.Value = "" ElseIf Val(Me!TextBox4.Value) <> 0 And Val(Me!TextBox4.Value) <= Val(Me!TextBox3.Value) Then MsgBox "データ終了行はデータ開始行より大きくしてください。データ終了行を指定しない場合は何も入力しないでください。", vbCritical, cPrgName Me!TextBox4.Value = "" End If End Sub Private Function LsGetPath(FullPath As String, FileName As String) As String '機能 : フルパス名から Path名 とファイル名を取得する '引数 : FullPath = 取得したいファイル名のフルパス名 '戻り値: Path名 ファイル名 Const MAX_PATH = 5120 Dim StrBuf As String, longret As Long StrBuf = Space$(MAX_PATH) If GetFileTitle(FullPath, StrBuf, MAX_PATH) = 0 Then FileName = Left$(StrBuf, InStr(StrBuf, vbNullChar) - 1) LsGetPath = Left$(FullPath, Len(FullPath) - Len(FileName) - 1) End If End Function Private Sub UserForm_Initialize() '口座振替用の全銀項目を設定 選択項目(1, 6) = "*" 選択項目(1, 14) = "" 選択項目(1, 15) = "*" 選択項目(1, 16) = "*" 選択項目(1, 17) = "*" 選択項目(0, 2) = "振替銀行番号" 選択項目(0, 1) = "データ区分" 選択項目(0, 3) = "振替銀行名" 選択項目(0, 4) = "＊振替支店番号" 選択項目(0, 5) = "振替支店名" 選択項目(0, 6) = "手形交換所番号" 選択項目(0, 7) = "＊預金種目" 選択項目(0, 8) = "＊口座番号" 選択項目(0, 9) = "＊振替人名" 選択項目(0, 10) = "＊振替金額" 選択項目(0, 11) = "新規コード" 選択項目(0, 12) = "顧客コード１" 選択項目(0, 13) = "顧客コード２" 選択項目(0, 14) = "振替結果" 選択項目(0, 15) = "ＥＤＩ識別表示" 選択項目(0, 16) = "ＥＤＩ情報" 選択項目(0, 17) = "手数料区分" ListBox1Set ComboBox1_Click On Error Resume Next If Me!ScrollBar1.Value Then Me!ScrollBar1.Value = 1 On Error GoTo 0 End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) 'フォームが閉じられたら読込ﾌｧｲﾙのブックを閉じる On Error Resume Next ActiveWorkbook.Close SaveChanges:=False End Sub |
||
| ABConv_Ref.xlsのダウンロード(ABConv_Ref.LZH) | ||
（UPD:02/12/07） |
||