| |
いつもとても勉強にさせて頂いてます。
今回初の投稿になりますが、何卒よろしくお願いいたします。
■状況
(スペック)
WinXP
Access2003
Excel2003
(目的)
複数のExcelファイル(任意指定、複数指定可)のシート(固有名指定)をアクセスにインポートする。
(経過)
1.[GetOpenFileName]を呼び出し、ダイアログからファイルパスを任意・複数取得
2.Excel.Application.WorkBook.Openでエクセルファイルをオープン
3.DAOでAccessTableへ保存
*2.でエクセルの保護をしているため[TransferSpreadSheet]ﾒｿｯﾄﾞは使用不可
(問題?困っていること)
1.のダイアログから複数のファイルを選択した場合、なぜか『8188』Byte以上になるとそれ以降が削除されます。
以下記述内容です。*エラー処理は省いてます。
■[GetOpenFileName]の標準ﾓｼﾞｭｰﾙ
Public Enum enmGetFileNameView
gfnViewDetail
gfnViewPreview
gfnViewPropewty
gfnViewList
gfnViewLargeIcons
gfnViewSmallIcons
gfnViewTiles = 8
End Enum
Public Enum enmGetFileNameFlags
gfnFlagsoverWritePrompt = &H1
gfnFlagsSetCurDir = &H4
gfnFlagsAllowMultiSelect = &H8
gfnFlagsSelectFolder = &H20
gfnFlagsEnableView = &H40
End Enum
Public Enum enmGetFileNameFOpen
gfnFOpenOpen = -1
gfnFOpenSaveAs = 0
End Enum
Function wh_GetFileName( _
Optional hwndOner As Long, _
Optional AppName As String, _
Optional DlgTitle As String, _
Optional OpenTitle As String, _
Optional FILE As String, _
Optional InitialDir As String, _
Optional FILTER As String, _
Optional FilterIndex As Long, _
Optional View As enmGetFileNameView, _
Optional flags As enmGetFileNameFlags, _
Optional fOpen As enmGetFileNameFOpen _
) As String
Const ENABLE_WIZHOOK = 51488399
Const DISABLE_WIZHOOK = 0
Dim strFILE As String
Dim lngResult As Long
If (hwndOwner = 0) Then hwndOwner = Application.hWndAccessApp
If (AppName = "") Then AppName = Application.Name
strFILE = FILE
If (FILTER = "") Then FILTER = "すべてのファイル(*.*)|*.*"
WizHook.Key = ENABLE_WIZHOOK
lngResult = WizHook.GetFileName( _
hwndOwner, _
AppName, _
DlgTitle, _
OpenTitle, _
strFILE, _
InitialDir, _
FILTER, _
FilterIndex, _
View, _
flags, _
fOpen)
WizHook.Key = DISABLE_WIZHOOK
wh_GetFileName = strFILE
End Function
■実行プロシージャ
Sub sample()
'---ファイルの取得処理---
Const DLG_TITLE = "データインポート"
Const FILTER_ = "Excelファイル(*.xls)|*.xls"
Dim INITIAL_DIR As String
INITIAL_DIR = CurrentProject.Path
Dim strFILE As String
strFILE = wh_GetFileName(, , _
DLG_TITLE, , , INITIAL_DIR, FILTER_, _
, , gfnFlagsAllowMultiSelect, _
gfnFOpenOpen)
If strFILE = vbNullString Then
Exit Sub
End If
MsgBox LenB(strFILE) '←ここで問題であろうByte数を調べました。
Debug.Print strFILE '←一応表示もしてみました。
DoCmd.Hourglass True
'---データの保存処理---
Dim dbs As DAO.Database
Dim rst As DAO.Recordset
Dim xls As Excel.Application
Dim wkb As Excel.Workbook
Dim vntList As Variant
Dim CNT As Long
Dim IDX As Long
''---保存先の設定---
Set dbs = CurrentDb
Set rst = dbs.OpenRecordset(Name:="T_Test", Type:=dbOpenTable)
Set xls = CreateObject("Excel.Application")
''---ファイル取得情報を区切る---
Dim ret, myFILE
ret = Split(strFILE, vbTab)
For Each myFILE In ret
''---エクセルファイルオープン---
Set wkb = xls.Workbooks.Open(FileName:=myFILE, ReadOnly:=True _
, Password:="pass", WriteResPassword:="pass")
With wkb.Worksheets("Sheet1").Range("A1").CurrentRegion
''---データが1行でない場合---
If Not (.Rows.Count = 1) Then
Let vntList = .Resize(.Rows.Count - 1).offset(1, 0).Value
'''---レコードの保存(選択範囲内ループ)---
For CNT = LBound(vntList, 1) To UBound(vntList, 1)
rst.AddNew
For IDX = LBound(vntList, 2) To UBound(vntList, 2)
Let rst.Fields(IDX - 1).Value = vntList(CNT, IDX)
Next
rst.Update
Next
End If
End With
Next myFILE
''---解放処理---
wkb.Close SaveChanges:=False
xls.Quit
Set wkb = Nothing
Set xls = Nothing
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing
DoCmd.Hourglass False
MsgBox "正常にインポートされました。"
End Sub
以上です。
ヘルプを見てみましたが、String型で2.0GB以上の格納が可能とあるので「？」です。
恐れ入りますがよろしくお願いいたします。
|
|
![[未読]](./data/access/image/read_icon.gif){kind=icon}
