FC2ブログ

スポンサーサイト 


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

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

Excel ファイルのプレビュー 


今回は VBA 記述内容について、ほとんど説明しません。
面白そうだな・・・ とか思われた方で、コードが読める方を対象にしたいと思います。

ここでは、テーブル / クエリ 等は全く関係なく、フォームだけの操作になります。
やっている事は、
・Excel ファイル、もしくは csv ファイルを指定して、プレビューしようというもの・・・

標準モジュール「Module1」に用意した MkFrm() を実行すると、以下のフォームが出来上がります。

kEnt176D

で、「Module1」中盤以降のコメントにしたものをフォームに転記し、コメントを外すと動くようになります。
起動すると、以下の表示になります。

kEnt176

テキストボックス部分をダブルクリックすると、ファイルダイアログが表示され・・・・
プレビューしたい Excel ファイルを選択・開くと、以下の表示に変わります。
(サンプルファイルに同梱した kEnt176.xls を指定した場合)

kEnt176_1

で、「home」「左」「右」「上」「下」ボタンでプレビュー位置が変わります。
また、クリックすると、行・列にそれなりの色が付きます。

kEnt176_2  kEnt176_3

これは Vector に登録していたものの一部を簡略化したものになります。
(実際には、インポートしたい部分をプレビュー上で指示して・・・)
(それを、用意したテーブルに合致する様に分割しながら・必要な部分だけを・・・)
(まっ、この部分だけでも使えるかな・・・ ということで・・・)

不明点等あれば、コメント頂ければと思います。
 
標準モジュール「Module1」に用意した MkFrm() を実行すると、フォームが出来上がります。
記述していたものは以下
Const IPX = 567
Const LABW = 2 * IPX

Public Sub MkFrm()
  Dim frm As Form

  Set frm = CreateForm
  DoCmd.RunCommand acCmdFormHdrFtr

  With frm
    .DefaultView = 0
    .RecordSelectors = False
    .NavigationButtons = False
    .DividingLines = False
    .ScrollBars = 0
    .Section(acFooter).Height = 0
    .PopUp = True
    .AutoCenter = True
    .HasModule = True
  End With

  Call MkHead(frm)
  Call MkDetail(frm)

  Set frm = Nothing
End Sub

Private Sub MkHead(frm As Form)
  Dim i As Long

  On Error Resume Next
  With CreateControl(frm.Name, acTextBox, acHeader)
    .Name = "txt1"
    .Top = 0.3 * IPX
    .Left = 5 * IPX
    .Height = 0.5 * IPX
    .Width = 14 * IPX
  End With
  With CreateControl(frm.Name, acLabel, acHeader, "txt1")
    .Name = "lab_txt1"
    .TextAlign = 3
    .Caption = "Excel ファイル名"
    .Top = 0.3 * IPX
    .Left = 1 * IPX
    .Height = 0.5 * IPX
    .Width = 3.8 * IPX
  End With

  With frm.Section(acHeader)
    .Height = 1 * IPX
    .BackColor = RGB(255, 255, 255)
  End With
End Sub

Private Sub MkDetail(frm As Form)
  Dim iTop As Long
  Dim i As Long, j As Long

  On Error Resume Next
  With CreateControl(frm.Name, acComboBox, acDetail)
    .Name = "cbx1"
    .Top = 0.3 * IPX
    .Left = 5 * IPX
    .Height = 0.5 * IPX
    .Width = 4 * IPX
    .RowSourceType = "Value List"
    .AllowValueListEdits = False
    .TabStop = False
  End With
  With CreateControl(frm.Name, acLabel, acDetail, "cbx1")
    .Name = "lab_cbx1"
    .TextAlign = 3
    .Caption = "シート選択"
    .Top = 0.3 * IPX
    .Left = 1 * IPX
    .Height = 0.5 * IPX
    .Width = 3.8 * IPX
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btn0"
    .Caption = "home"
    .Top = 0.8 * IPX
    .Left = 0.8 * IPX
    .Height = 0.7 * IPX
    .Width = 1.75 * IPX
    .TabStop = False
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btnC1"
    .Caption = "左"
    .Top = 0.2 * IPX
    .Left = 10.5 * IPX
    .Height = 0.7 * IPX
    .Width = 1.8 * IPX
    .TabStop = False
  End With
  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btnC2"
    .Caption = "右"
    .Top = 0.2 * IPX
    .Left = 12.5 * IPX
    .Height = 0.7 * IPX
    .Width = 1.8 * IPX
    .TabStop = False
  End With

  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btnR1"
    .Caption = "上"
    .Top = 2 * IPX
    .Left = 0.2 * IPX
    .Height = 1.8 * IPX
    .Width = 0.7 * IPX
    .TabStop = False
  End With
  With CreateControl(frm.Name, acCommandButton, acDetail)
    .Name = "btnR2"
    .Caption = "下"
    .Top = 4 * IPX
    .Left = 0.2 * IPX
    .Height = 1.8 * IPX
    .Width = 0.7 * IPX
    .TabStop = False
  End With

  iTop = 1.5 * IPX
  For i = 1 To 20
    With CreateControl(frm.Name, acLabel, acDetail)
      .Name = "labR" & i
      .TextAlign = 2
      .Caption = i
      .Top = iTop
      .Left = 1 * IPX
      .Height = 0.5 * IPX
      .Width = 2.5 * IPX - .Left
      .BorderStyle = 1
      .BackStyle = 1
      .BackColor = RGB(240, 240, 240)
    End With
    For j = 1 To 10
      If (i = 1) Then
        With CreateControl(frm.Name, acLabel, acDetail)
          .Name = "labC" & j
          .TextAlign = 2
          .Caption = Chr(Asc("A") + j - 1)
          .Top = iTop - 0.5 * IPX
          .Left = (j - 1) * LABW + 2.5 * IPX
          .Height = 0.5 * IPX
          .Width = LABW
          .BorderStyle = 1
          .BackStyle = 1
          .BackColor = RGB(240, 240, 240)
        End With
      End If
      With CreateControl(frm.Name, acLabel, acDetail)
        .Name = "R" & i & "C" & j
        .TextAlign = 1
        .Caption = ""
        .Top = iTop
        .Left = (j - 1) * LABW + 2.5 * IPX
        .Height = 0.5 * IPX
        .Width = LABW
        .BorderStyle = 1
        .BackStyle = 0
        .BackColor = RGB(255, 255, 255)
      End With
    Next
    iTop = iTop + 0.5 * IPX
  Next
  frm.Width = 23 * IPX
  With frm.Section(acDetail)
    .Height = iTop + 0.5 * IPX
    .BackColor = RGB(255, 255, 255)
  End With
End Sub

 
で、出来上がったフォームのデザインは

kEnt176D

の様になります。
フォームが出来上がったので、
・「Module1」中盤以降のコメントにしている部分を転記してコメントを外す・・・ もしくは
・既に出来上がっているフォーム「F1」から記述を転記する
どちらでも良いので、作成したフォームに転記します。
これで、ある程度動作する様になります。

ちなみに、出来上がったフォームに記述するものは以下
Dim oApp As Object
Dim vBuff As Variant
Dim iShowRow As Long ' 相対移動量(行方向)
Dim iShowCol As Long ' 相対移動量(列方向)
Dim iClickRow As Long ' 選択中行(絶対位置)
Dim iClickCol As Long ' 選択中列(絶対位置)


Private Function NumToString(ByVal iNum As Long) As String
  Dim sS As String
  Dim iBase As Long, i As Long

  iBase = Asc("A")
  sS = ""
  While (iNum > 0)
    i = (iNum - 1) Mod 26
    sS = Chr(iBase + i) & sS
    iNum = (iNum - 1) \ 26
  Wend
  NumToString = sS
End Function

Private Sub ExcelFileClose()
  Dim i As Long

  On Error Resume Next
  If (Not oApp Is Nothing) Then
    With oApp
      For i = 1 To 10
        If (.Workbooks.Count = 0) Then Exit For
        .Workbooks(1).Close SaveChanges:=False
      Next
    End With
  End If
  vBuff = Empty
  Me.Caption = ""
End Sub

Private Function ExcelOpen(sPath As String) As Boolean
  Dim sS As String
  Dim v As Variant

  ExcelOpen = False
  On Error GoTo ERR_HND
  If (oApp Is Nothing) Then
    Set oApp = CreateObject("Excel.Application")
  Else
    Call ExcelFileClose
  End If
  With oApp
    .Workbooks.Open FileName:=sPath, ReadOnly:=True
    With .ActiveWorkbook
      Me.Caption = .Name
      sS = ""
      For Each v In .Worksheets
        sS = sS & ";""" & v.Name & """"
      Next
      sS = Mid(sS, 2)
      Me.cbx1.RowSource = sS
      Me.cbx1.Requery
      Me.cbx1 = Me.cbx1.ItemData(0)
      .Worksheets(Me.cbx1.Value).Activate
    End With
    vBuff = .Range(.Cells(1, 1), .Cells(50, 50))
    Call ExcelScreenShow(True)
  End With
  ExcelOpen = True
ERR_HND:
End Function

Private Sub ExcelScreenShow(bInit As Boolean)
  Dim iRow As Long, iCol As Long
  Dim iRBStyle As Long, iCBStyle As Long

  If (IsEmpty(vBuff)) Then Exit Sub
  If (bInit) Then
    iShowRow = 0
    iShowCol = 0
    iClickRow = 0
    iClickCol = 0
  End If

  Me.Painting = False
  For iRow = 1 To 20
    iRBStyle = 0
    If ((iShowRow + iRow) = iClickRow) Then iRBStyle = 1
    Me("labR" & iRow).Caption = iShowRow + iRow
    For iCol = 1 To 10
      If (iRow = 1) Then Me("labC" & iCol).Caption = NumToString(iShowCol + iCol)
      iCBStyle = 0
      If ((iShowCol + iCol) = iClickCol) Then iCBStyle = 1
      With Me("R" & iRow & "C" & iCol)
        .Caption = vBuff(iShowRow + iRow, iShowCol + iCol)
        Select Case True
          Case iRBStyle = 1 And iCBStyle = 1
            .BackStyle = 1
            .BackColor = RGB(255, 255, 198)
          Case iRBStyle = 1
            .BackStyle = 1
            .BackColor = RGB(255, 240, 240)
          Case iCBStyle = 1
            .BackStyle = 1
            .BackColor = RGB(240, 255, 255)
          Case Else
            .BackStyle = 0
        End Select
      End With
    Next
  Next
  Me.Painting = True
End Sub

Private Sub DetailHidden()
  Me.Section(acDetail).Visible = False
  Me.InsideHeight = Me.Section(acHeader).Height
End Sub

Private Function fncLabRClick(iNum As Long)
  iClickRow = iShowRow + iNum
  Call ExcelScreenShow(False)
End Function

Private Function fncLabCClick(iNum As Long)
  iClickCol = iShowCol + iNum
  Call ExcelScreenShow(False)
End Function

Private Function fncRCClick(iRow As Long, iCol As Long)
  iClickRow = iShowRow + iRow
  iClickCol = iShowCol + iCol
  Call ExcelScreenShow(False)
End Function

Private Sub Form_Load()
  Dim iRow As Long, iCol As Long

  Call DetailHidden
  For iRow = 1 To 20
    Me("labR" & iRow).OnClick = "=fncLabRClick(" & iRow & ")"
    For iCol = 1 To 10
      If (iRow = 1) Then Me("labC" & iCol).OnClick = "=fncLabCClick(" & iCol & ")"
      Me("R" & iRow & "C" & iCol).OnClick = "=fncRCClick(" & iRow & "," & iCol & ")"
    Next
  Next
End Sub

Private Sub Form_Close()
  Call ExcelFileClose
  If (Not oApp Is Nothing) Then oApp.Quit
  Set oApp = Nothing
End Sub

Private Sub txt1_AfterUpdate()
  Dim sS As String

  If (IsNull(Me.txt1)) Then
    Call ExcelFileClose
    Call DetailHidden
    Exit Sub
  End If

  sS = Me.txt1
  If ((Mid(sS, 2, 2) <> ":\") And (Left(sS, 2) <> "\\")) Then
    sS = CurrentProject.Path & "\" & sS
  End If
  If (ExcelOpen(sS)) Then
    Me.InsideHeight = Me.Section(acHeader).Height _
            + Me.Section(acDetail).Height
    Me.Section(acDetail).Visible = True
  End If
End Sub

Private Sub txt1_DblClick(Cancel As Integer)
  Dim sFullPath As String, sFileName As String

  Cancel = True
  If (appFileNameGet(Me.hwnd, "対象ファイルの選択", sFullPath, sFileName)) Then
    Me.txt1 = sFullPath
    Call txt1_AfterUpdate
  End If
End Sub

Private Sub cbx1_BeforeUpdate(Cancel As Integer)
  If (IsNull(Me.cbx1)) Then Cancel = True
End Sub

Private Sub cbx1_AfterUpdate()
  With oApp
    If (.Workbooks.Count = 0) Then Exit Sub
    .Worksheets(Me.cbx1.Value).Activate
    vBuff = .Range(.Cells(1, 1), .Cells(50, 50))
  End With
  Call ExcelScreenShow(True)
End Sub


Private Sub btn0_Click()
  iShowRow = 0
  iShowCol = 0
  Call ExcelScreenShow(False)
End Sub

Private Sub btnC1_Click()
  Dim i As Long

  i = iShowCol
  iShowCol = iShowCol - 5
  If (iShowCol < 0) Then iShowCol = 0
  If (i <> iShowCol) Then Call ExcelScreenShow(False)
End Sub

Private Sub btnC2_Click()
  Dim i As Long

  i = iShowCol
  iShowCol = iShowCol + 5
  If (iShowCol > UBound(vBuff, 2) - 10) Then iShowCol = UBound(vBuff, 2) - 10
  If (i <> iShowCol) Then Call ExcelScreenShow(False)
End Sub

Private Sub btnR1_Click()
  Dim i As Long

  i = iShowRow
  iShowRow = iShowRow - 10
  If (iShowRow < 0) Then iShowRow = 0
  If (i <> iShowRow) Then Call ExcelScreenShow(False)
End Sub

Private Sub btnR2_Click()
  Dim i As Long

  i = iShowRow
  iShowRow = iShowRow + 10
  If (iShowRow > UBound(vBuff, 1) - 20) Then iShowRow = UBound(vBuff, 1) - 20
  If (i <> iShowRow) Then Call ExcelScreenShow(False)
End Sub

 
※ いろいろな記述の方法を試してみています。
例えば、最後の以下部分
Private Sub btnR2_Click()
  Dim i As Long

  i = iShowRow
  iShowRow = iShowRow + 10
  If (iShowRow > UBound(vBuff, 1) - 20) Then iShowRow = UBound(vBuff, 1) - 20
  If (i <> iShowRow) Then Call ExcelScreenShow(False)
End Sub

普通なら、現状の iShowRow の値によって処理を切り分け・・・・
これだけで、わかる方にはわかりますでしょうか・・・

まぁ、ソコソコ動きますけど・・・ 遅いは遅いですね
でも、必要な部分だけをインポートしたい・・・ やはり、プレビューして、範囲を指定する・・・
これは必要なんじゃないでしょうか・・・

後は、いろいろと細工して行けば・・・

※ 通常インポート・・・ っていうと、セルの Value が対象の様だけど・・・
  Excel から text でデータを入手すると、書式が適用された物を対象にする事が出来るみたい・・・
  ただ、それなりに遅くなりますけどね・・・

※ エラー処理で手を抜いている部分もあります
例えば、
・まともな Excel ファイル指定で表示していた時、さらに違うファイル(Excelで扱えないファイル)を
 指定した場合、コンボボックス等いじっても反応はありません。


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt176_2000.zipkEnt176_2003.zipkEnt176_2007.zip
 サイズ 71,16670,61972,937
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

※ 確認用 Excel ファイル kEnt176.xls も同梱されています
関連記事

2013/09/17

Category: サンプルかな

TB: --  /  CM: 0

top △

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

top △

コメントの投稿

Secret

top △


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