Excel で Access の画面設定

画面設定.vba

Sub メニュー()
  On Error GoTo subError
  Dim wMenu  As String
  
  wMenu = "項目の追加,項目位置を保存,フォーム画面表示"
  
  n = f_メニュー("タイトル", wMenu, "選択してください", 0)
  If n = 0 Then Exit Sub
  '--- Exit ---
  
  '(メニュー実行)
  If n = 1 Then Call 項目を作る
  If n = 2 Then Call 項目位置を保存
  If n = 3 Then Call フォーム表示

subExit:
  Exit Sub

subError:
  MsgBox Error$ & "(#" & Trim(Trim(Err.Number)) & ")", vbOKOnly + vbExclamation _
  , "確認"
  Resume subExit
End Sub

'項目を作る
Sub 項目を作る()
  On Error GoTo subError
  Dim wNO   As Integer
  Dim wLeft As Single, wTop As Single, wWidth As Single, wHeight As Single
  Dim wSTR  As String
  Dim wTab  As Single
   
  Call s_DeleteShape
  
  For wNO = 1 To 20
    wTab = Int((wNO - 1) / 10) * 350
    
    '丸四角
    wTop = (((wNO - 1) Mod 10)) * 30 + 15
    wLeft = wTab + 10
    wWidth = 100
    wHeight = 25
    wSTR = "項目名" & Trim(Str(wNO))
    Call s_CreateMaruLabel(wLeft, wTop, wWidth, wHeight, wNO)
    
    '四角
    wLeft = wTab + 120
    wWidth = 200
    wSTR = "全角"
    Call s_CreateKakuBox(wLeft, wTop, wWidth, wHeight, wNO)
  Next wNO
  
  Range("A1").Select

subExit:
  Exit Sub

subError:
  MsgBox Error$ & "(#" & Trim(Trim(Err.Number)) & ")", vbOKOnly + vbExclamation _
  , "確認"
  Resume subExit
End Sub

'丸四角
Private Sub s_CreateMaruLabel(qLeft As Single, qTop As Single, qWidth As Single, qHeight As Single, qNO As Integer)
  Dim wName As String
  Dim wRGB  As Long
  Dim wSTR  As String
  
  ActiveSheet.Shapes.AddShape(msoShapeRoundedRectangle, qLeft, qTop, qWidth, qHeight).Select

  wName = "MaruLbl" & Format(qNO, "000"): Call s_ShapeName(wName)        'シェイプ名前
  wRGB = RGB(234, 234, 234):                Call s_BackColor(wRGB)          '背景色(RGB)
  wSTR = "項目名" & Trim(Str(qNO)):         Call s_ShapeCaption(wSTR, "R")  'テキスト編集
End Sub

'四角
Private Sub s_CreateKakuBox(qLeft As Single, qTop As Single, qWidth As Single, qHeight As Single, qNO As Integer)
  Dim wName As String
  Dim wRGB  As Long
  Dim wSTR  As String
  
  ActiveSheet.Shapes.AddShape(msoShapeRectangle, qLeft, qTop, qWidth, qHeight).Select

  wName = "KakuTxt" & Format(qNO, "000"): Call s_ShapeName(wName)           'シェイプ名前
  wRGB = RGB(255, 255, 255):              Call s_BackColor(wRGB)            '背景色(RGB)
  wSTR = "半角/指定なし":                 Call s_ShapeCaption(wSTR, "L")    'テキスト編集
End Sub


'項目を消す
Private Sub s_DeleteShape()
  Dim wObj   As Object
  Dim wName  As String
  
  For Each wObj In ActiveSheet.Shapes
    wName = wObj.Name
    If Left(wName, 4) = "Maru" Or Left(wName, 4) = "Kaku" Then
      ActiveSheet.Shapes(wName).Delete
    End If
  Next
End Sub


'項目位置を保存
Sub 項目位置を保存()
  On Error GoTo subError

  Set ADB = New ADODB.Connection

  'DB接続用SQL
  Call syADOAccdbOpen
  
  '背景色による集計値
  ADB.Execute "DELETE FROM T_SwShapeInfo ;"

  SQL1 = "SELECT * FROM T_SwShapeInfo ;"
  Set ARST1 = New ADODB.Recordset
  ARST1.Open SQL1, ADB, adOpenKeyset, adLockOptimistic
  
  Call s_GetShapeInfo

  ARST1.Close
  ADB.Close
  Set ARST1 = Nothing
  Set ADB = Nothing


  n = f_確認("保存しました。", "i", "確認")

subExit:
  Exit Sub

subError:
  ARST1.Close
  ADB.Close
  Set ARST1 = Nothing
  Set ADB = Nothing
  
  MsgBox Error$ & "(#" & Trim(Trim(Err.Number)) & ")", vbOKOnly + vbExclamation _
  , "確認"
  Resume subExit
End Sub

Private Sub s_GetShapeInfo()
  Dim wObj    As Object
  Dim wLeft   As Single
  Dim wTop    As Single
  Dim wWidth  As Single
  Dim wHeight As Single
  Dim wSTR    As String
  Dim wIME    As String
  Dim wName   As String
  Dim wNO     As Integer
  
  For Each wObj In ActiveSheet.Shapes
    wName = wObj.Name
    wLeft = wObj.Left
    wTop = wObj.Top
    wWidth = wObj.Width
    wHeight = wObj.Height
    
    If Left(wName, 4) = "Maru" Or Left(wName, 4) = "Kaku" Then
      wNO = wNO + 1
      If Left(wName, 4) = "Maru" Then wSTR = wObj.TextFrame.Characters.Text
      If Left(wName, 4) = "Kaku" Then wSTR = wObj.TextFrame.Characters.Text
      
      ARST1.AddNew
      ARST1![IDno] = wNO
      ARST1![Shape] = wName
      ARST1![Caption] = wSTR
      ARST1![Left] = wLeft
      ARST1![Top] = wTop
      ARST1![Width] = wWidth
      ARST1![Height] = wHeight
      ARST1.Update
    End If
  Next
    
End Sub

                                
Public Sub syADOAccdbOpen()
  Dim wMDBPath  As String
  Dim wMDB      As String
  
  wMDBPath = ThisWorkbook.Path
  wMDB = wMDBPath & "\YUGE_Database.accdb"
  
  'DB接続用SQL
  ADB.Provider = "Microsoft.Ace.OLEDB.12.0; "
  ADB.ConnectionString = "Data Source=" & wMDB & ";"
  ADB.Open
End Sub