スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excelのハイパーリンク情報をインポートする 


ハイパーリンクについては、過去記事「ハイパーリンクって、、、セキュリティは」でも扱っていました。
私自体はハイパーリンク型は使わないのですが、データを取り込む元の状態を維持したいとかなると・・・
特に、Excel でハイパーリンク設定されているものをインポートしつつ、ハイパーリンクとして機能させるには・・・
ということで、やってみたものになります。
ま、きっかけは回答した事・・・・ですけど。

今回の添付ファイルには、Excelファイル「kEnt209.xls」とアクセスファイルの2つが入っています。
Excel ファイルには2つのシートがあって、
「Sheet1」が取り込む元となるもの(図左)
「Sheet2」は「Sheet1」の B4 からリンク( Sheet2!A1 )(図右)

kEnt209_Excel_1.jpg  kEnt209_Excel_2.jpg

この「Sheet2」はブログの記事一覧にもなっているので・・・
C列はハイパーリンクとしていませんが、1度編集状態にしてから Enter すればリンクが張られるようなので、簡単に記事に飛べると思います。

確認用フォームは以下

kEnt209_1.jpg

確認内容は、
1)回答したもの Samp1
2)DoCmd.TransferSpreadsheet を使った Samp2
3)Excel ファイル内でリンクしていたものを参照できるように Samp3
4)3)のやり方をチョッと変更してみたのが Samp4

これをやってみてわかった事は、
・DoCmd.TransferSpreadsheet では、表示されている文字列だけ
 (ハイパーリンクとしては機能しない)
・Excel の空白( Empty値 )をレコードセットでフィールドに代入すると Null になる
 
確認用に用意したテーブル「T1」は、
an:オートナンバ型
項目1:日付/時刻型
項目2:ハイパーリンク型
項目3:テキスト型
項目4:テキスト型
項目5:テキスト型


1)回答したもの Samp1

回答した時のハイパーリンクの位置はC列でしたがB列にしたので、その参照が異なるだけで同じものが以下

エラー処理の全くない例で良いですか

条件)
・テーブルは既に作成済み
・シートは A1 から埋まっており、1行目が項目名
(データは2行目から)
・その項目名と、テーブルのフィールド名は一致する
・C列がハイパーリンク設定されている
(ハイパーリンク設定されていなければ何もしない)

★ 部分を変更の上、試してみてください
事前にテーブルをクリアするとかは、ご自由に

なお、Excel を Quit する前に、エラー等で止まったら
Excel は起動されたままなので・・・

Public Sub Samp1()
  Dim rs As New ADODB.Recordset
  Dim vA As Variant
  Dim sS As String
  Dim iRow As Long, iCol As Long
  Const CTABLE As String = "T1" ' ★
  Const CFILE As String = "\kEnt209.xls" ' ★
  Const CSHEET As String = "Sheet1" ' ★

  With CreateObject("Excel.Application")
    With .Workbooks.Open(CurrentProject.Path & CFILE, ReadOnly:=True)
      With .Worksheets(CSHEET)
        vA = .Range("A1").CurrentRegion.Value
        sS = ""
        For iCol = 1 To UBound(vA, 2)
          sS = sS & ", [" & vA(1, iCol) & "]"
        Next
        sS = Mid(sS, 3)
        rs.Source = "SELECT " & sS & " FROM " & CTABLE & ";"
        rs.Open , CurrentProject.Connection _
              , adOpenForwardOnly, adLockOptimistic
        For iRow = 2 To UBound(vA)
          rs.AddNew
          For iCol = 1 To UBound(vA, 2)
            If (iCol = 2) Then ' B列 ★
              With .Cells(iRow, iCol).Hyperlinks
                If (.Count > 0) Then
                  With .Item(1)
                    sS = .TextToDisplay & _
                      "#" & .Address & _
                      "#" & .SubAddress & _
                      "#" & .ScreenTip
                    rs(iCol - 1) = sS
                  End With
                End If
              End With
            Else
              rs(iCol - 1) = vA(iRow, iCol)
            End If
          Next
          rs.Update
        Next
        rs.Close
      End With
      .Close False
    End With
    .Quit
  End With
End Sub

※ 上記 ★ 部分は修正済みで、実際のコード状には ★ マークは削除しています

ここでやっているのは、シートの項目の並び順をレコードセットのフィールド順にしたかったので、
        sS = ""
        For iCol = 1 To UBound(vA, 2)
          sS = sS & ", [" & vA(1, iCol) & "]"
        Next
        sS = Mid(sS, 3)
        rs.Source = "SELECT " & sS & " FROM " & CTABLE & ";"
で、その後は
              rs(iCol - 1) = vA(iRow, iCol)
とフィールド名とか使わずに、何番目・・・・で速く(?)設定できるように・・・かな?


2)DoCmd.TransferSpreadsheet を使った Samp2

Access に用意されているインポート用のものを使ってみたら・・・ということで

Public Sub Samp2()
  Const CTABLE As String = "T1"
  Const CFILE As String = "\kEnt209.xls"
  Const CSHEET As String = "Sheet1"

  DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel8 _
    , CTABLE, CurrentProject.Path & CFILE, True, CSHEET & "!"
End Sub

最後の CSHEET & "!" 部分は、CSHEET & "$" でも動くようです。
他の部分では、$ を使うので、$ で統一しておいた方が良い???
必ず Sheet1 から読み込みたかったので指定しましたが、指定しなければ1番左のシート???


3)Excel ファイル内でリンクしていたものを参照できるように Samp3

Public Sub Samp3()
  Dim rs As New ADODB.Recordset
  Dim vA As Variant, vK As Variant, vH As Variant
  Dim i As Long
  Const CTABLE As String = "T1"
  Const CFILE As String = "\kEnt209.xls"
  Const CSHEET As String = "Sheet1"

  With CreateObject("Excel.Application")
    With .Workbooks.Open(CurrentProject.Path & CFILE, ReadOnly:=True)
      With .Worksheets(CSHEET)
        vA = .Range("A1").CurrentRegion.Value
        For i = 2 To UBound(vA)
          With .Cells(i, 2).Hyperlinks
            If (.Count > 0) Then
              ReDim vH(3)
              With .Item(1)
                vH(0) = .TextToDisplay
                vH(1) = .Address
                If (Len(vH(1)) = 0) Then
                  vH(1) = CurrentProject.Path & CFILE
                End If
                vH(2) = .SubAddress
                vH(3) = .ScreenTip
                vA(i, 2) = Join(vH, "#")

              End With
            Else
              vA(i, 2) = Empty
            End If
          End With
        Next
      End With
      .Close False
    End With
    vK = .WorksheetFunction.Index(vA, 1)
    rs.Open CTABLE, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
    For i = 2 To UBound(vA)
      rs.AddNew vK, .WorksheetFunction.Index(vA, i)
    Next
    rs.Close
    .Quit
  End With
End Sub

まず、Samp1 から変更してみたのは
・Excel セル操作するものは初めにまとめてやっておいて
                vH(0) = .TextToDisplay
                vH(1) = .Address
                If (Len(vH(1)) = 0) Then
                  vH(1) = CurrentProject.Path & CFILE
                End If
                vH(2) = .SubAddress
                vH(3) = .ScreenTip
                vA(i, 2) = Join(vH, "#")
また、
.Address 部分にデータが無い=Excelファイル内のリンク・・・
という判断をして、空ならExcelファイルのフルパスを・・・

・ADO での新規データの登録には、 AddNew フィールドリスト, 値リスト
 の方法もあるので、それを使ってみた。
 フィールドリストにはExcel1行目の項目を使うので、Recordset をオープンする際のフィールドの並び順は問わず。
    vK = .WorksheetFunction.Index(vA, 1)
    rs.Open CTABLE, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
    For i = 2 To UBound(vA)
      rs.AddNew vK, .WorksheetFunction.Index(vA, i)
    Next


4)3)のやり方をチョッと変更してみたのが Samp4

Samp3 を確認していて疑問になったのが、Excel の値が空白(Empty)だったら・・・??
設定したフィールドの値は、Null ?? or 空文字 ??
そこで、値を設定する際 Empty 値なら Null に置き換えたものを設定する様に変更しただけのもの

Public Sub Samp4()
  Dim rs As New ADODB.Recordset
  Dim vA As Variant, vK As Variant, vH As Variant
  Dim i As Long
  Const CTABLE As String = "T1"
  Const CFILE As String = "\kEnt209.xls"
  Const CSHEET As String = "Sheet1"

  With CreateObject("Excel.Application")
    With .Workbooks.Open(CurrentProject.Path & CFILE, ReadOnly:=True)
      With .Worksheets(CSHEET)
        vA = .Range("A1").CurrentRegion.Value
        For i = 2 To UBound(vA)
          With .Cells(i, 2).Hyperlinks
            If (.Count > 0) Then
              ReDim vH(3)
              With .Item(1)
                vH(0) = .TextToDisplay
                vH(1) = .Address
                If (Len(vH(1)) = 0) Then
                  vH(1) = CurrentProject.Path & CFILE
                End If
                vH(2) = .SubAddress
                vH(3) = .ScreenTip
                vA(i, 2) = Join(vH, "#")
              End With
            Else
              vA(i, 2) = Empty
            End If
          End With
        Next
      End With
      .Close False
    End With
    vK = .WorksheetFunction.Index(vA, 1)
    rs.Open CTABLE, CurrentProject.Connection, adOpenForwardOnly, adLockOptimistic
    For i = 2 To UBound(vA)
      rs.AddNew vK, Empty2Null(.WorksheetFunction.Index(vA, i))
    Next
    rs.Close
    .Quit
  End With
End Sub

Private Function Empty2Null(ByVal vSrc As Variant) As Variant
  Dim v As Variant
  Dim i As Long

  For i = LBound(vSrc) To UBound(vSrc)
    If (IsEmpty(vSrc(i))) Then vSrc(i) = Null
  Next
  Empty2Null = vSrc
End Function


確認してみると、Empty は Null として設定されるようです。


以下に確認用フォームについて記述しますが、
実行する際には Access / Excel ファイルとも同じフォルダに置いてからにしてください。


確認用フォーム「F1」

kEnt209_1.jpg

テーブルをクリアしてから実行するか・・・の選択の後に各ボタンをクリックして実行します。
フォーカスのあるテキストボックスの値を表示します。
Tab キー等で移動後、どの様な値が設定されているか確認してみてください。
なお、フォームに記述していたVBAは以下となります。

Private Function GotFocusCtlValue()
  Dim sMsg As String

  With Me.ActiveControl
    sMsg = "今の " & .Name & " の値は" & vbCrLf
    If (IsNull(.Value)) Then
      sMsg = sMsg & "Null"
    ElseIf (Len(.Value) = 0) Then
      sMsg = sMsg & "空文字"
    Else
      sMsg = sMsg & .Value
    End If
    Me.labmsg.Caption = sMsg
  End With
End Function

Private Sub Form_Load()
  Dim ctl As Control

  For Each ctl In Me.Section(acDetail).Controls
    ctl.OnGotFocus = "=GotFocusCtlValue()"
  Next
End Sub

Private Sub InitTbl()
  If (Me.op1 = 0) Then
    CurrentProject.Connection.Execute "DELETE FROM T1;"
  End If
End Sub

Private Sub btn1_Click()
  Call InitTbl
  Call Samp1
  Me.Requery
End Sub

Private Sub btn2_Click()
  Call InitTbl
  Call Samp2
  Me.Requery
End Sub

Private Sub btn3_Click()
  Call InitTbl
  Call Samp3
  Me.Requery
End Sub

Private Sub btn4_Click()
  Call InitTbl
  Call Samp4
  Me.Requery
End Sub

 

動作確認概要

・Samp1

kEnt209_2.jpg

 Excel にハイパーリンク設定ないものは設定されない(そうなるように VBA 記述していたので)
 Excelファイル内でのリンク情報部分は、クリックしても何も起きない


・Samp2

kEnt209_3.jpg

 Excel でハイパーリンク設定されていようがいまいが、表示されている文字列だけが設定される
 ハイパーリンクとして機能しない
 2007 で実行すると、「名前の自動修正保存エラー」テーブルが出来上がる

kEnt209_Err_2007.jpg

 これは、Sheet1 の A2 が空白だから??
 (2000 / 2003 ではそういう事は無かった)


・Samp3

kEnt209_4.jpg

 Excel にハイパーリンク設定ないものは設定されない
 Excelファイル内でのリンク情報部分も、クリックするとExcelファイルが立ち上がる


・Samp4
 Samp3 と同じ(Empty を、わざわざ Null に置換える必要はないみたい)


やっぱり、ハイパーリンク型は好きになれないな・・・
フォーム上で表示していて編集し難いし・・・
Excel が起動されると、ツールバーの Web が表示されてくるし・・・(2000/2003)


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt209_2000.zipkEnt209_2003.zipkEnt209_2007.zip
 サイズ 41,93743,55845,577
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化
※ インポート確認用 Excel ファイル kEnt209.xls 同梱
関連記事

2015/02/26

Category: サンプルかな

TB: --  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。