[.NET]Hashテーブルを使ったクラス

From Evernote:

[.NET]Hashテーブル(辞書)を使ったクラス

Hashテーブル（dictionary型）を使ったクラスを持っておいて

１度宣言すれば

ループ時等で何度もマスタ読みに行かなくてラク。

'本文では==================================

Dim GetTanto As New GetTanto  '宣言

Dim TestArray(3) = {1000,2000,3000} 

For i As Integer = 0 To TestTrray.Length - 1

   debug GetTanto.GetName(TestArray(i))　'表示

Next

'クラスは=======================================

'class_担当者をとってくる -------

Public Class GetTanto

# Region "Member"

        Private NameTBL As New System.Collections.Generic.Dictionary(Of Integer , String)

# End Region

# Region "Constructor"

        Sub New ()

            MyClass.ReadMaster()

        End Sub

# End Region

# Region "ReadMaster"

        Sub ReadMaster()

            Dim strSQL As String = "SELECT * from M_ 担当者"

            Dim objDS As New DataSet

            ADONET.FillDataset(STRCON, objDS, "Table" , strSQL)

            For i As Integer = 0 To objDS.Tables("Table").Rows.Count - 1

                With objDS.Tables("Table").Rows(i)

                    NameTBL.Add(.Item( "担当コード "), .Item( "担当者"))

                End With

            Next

        End Sub

# End Region

# Region "GetName"

        Public Function GetName( ByVal No As Object) As String

            Dim tmp As String = ""

            '合致するなら

            If NameTBL.ContainsKey(No) Then

               tmp = NameTBL(No).ToString.Trim

            End If

            Return tmp

        End Function

# End Region

End Class

From Evernote:

[ACCESS]ACCESSファイル内のﾚﾎﾟｰﾄのプリンタ指定をﾃｷｽﾄファイルで吐き出す

ACCESSﾌｧｲﾙ内ﾚﾎﾟｰﾄのプリンタ指定をﾃｷｽﾄファイルで吐き出します。

テストしてたら現場のプリンタから出ちゃったとかあるので…。

（９７以降対応）

'--------------------------------------------------------------------------------

Function Z_プリンタ調査()

    Dim motoName As String
    motoName = "プリンタ" & Format(Today, "ddhhss")
  
    Dim strMdbName As String
    strMdbName = CurrentDb.Name
  
    SaveModules strMdbName, "", "C:\******.txt"

End Function


Public Sub SaveModules(strMdbName As String, strPw As String, strExpFile As String)
    Dim dbs As DAO.Database
    Dim objAcc As Access.Application
    Dim mdl As Module
    Dim docWork As DAO.Document
    Dim frm As Form
    Dim rpt As Report

    On Error Resume Next

' リストを出力するファイル名
    'Const FILENAME = strExpFile
  
    Open strExpFile For Output As #100
    Print #100, "■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, "■     MDB Name : " & strMdbName
    Print #100, "■    CreateDay : " & Now
    Print #100, "■"
    Print #100, "■    Copyright (c) 1997-20xx 7key All Rights Reserved."
    Print #100, "■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
  

  
    Set dbs = DBEngine.Workspaces(0).OpenDatabase(strMdbName, False, False, ";PWD=" & strPw)
    Set objAcc = GetObject(strMdbName)
  


    Print #100, ""
    Print #100, ""
    Print #100, "■■■  REPORTS   ■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
  
    For Each docWork In dbs.Containers!Reports.Documents
        On Error Resume Next
        objAcc.DoCmd.OpenReport docWork.Name, acDesign
        Set rpt = objAcc.Reports(docWork.Name)
            Print #100, ""
            Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
            Print #100, "□ Module Name : " & docWork.Name
            Print #100, "□     Created : " & docWork.DateCreated
            Print #100, "□    Modified : " & docWork.LastUpdated
            Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
            Print #100, rpt.Printer.DeviceName
            Print #100, rpt.Printer.DriverName
        objAcc.DoCmd.Close acReport, docWork.Name, acSavePrompt
    Next
  
    Print #100, ""
    Print #100, ""
    Print #100, "■■■  END   ■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
  
    Close #100
    dbs.Close
    Set dbs = Nothing

End Sub

From Evernote:

[ACCESS]ACCESSﾌｧｲﾙ内のﾌｫｰﾑ、ﾚﾎﾟｰﾄのデータソースをﾃｷｽﾄファイルで吐き出す。

ACCESSﾌｧｲﾙ内のﾌｫｰﾑ、ﾚﾎﾟｰﾄに埋め込まれているデータソースを調べるのはメンドクサイので、

データソース内容一覧をﾃｷｽﾄファイルで吐き出します。

（９７以降対応）

ﾌｫｰﾑの場合は、それぞれのコントロールを見て、

データソースを持っていれば書き出しています。

'--------------------------------------------------------------------------------

Private Sub Click ()

    Dim motoName As String
    motoName = "データソース" & Format(Today, "ddhhss")
  
    Dim strMdbName As String
  
    SaveModules strMdbName, "", "C:\******.txt"

End Sub

Sub SaveModules (strMdbName As String, strPw As String, strExpFile As String)
  
    Dim dbs As Database
    Set dbs = DBEngine(0)(0)
    Dim docWork As Document
    Dim frm As Form
    Dim rpt As Report

    On Error Resume Next

' リストを出力するファイル名
    'Const FILENAME = strExpFile
  
    Open strExpFile For Output As #100
    Print #100, "■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, "■     MDB Name : " & strMdbName
    Print #100, "■    CreateDay : " & Now
    Print #100, "■"
    Print #100, "■    Copyright (c) 1997-20xx 7key All Rights Reserved."
    Print #100, "■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
          
    Print #100, ""
    Print #100, "■■■  FORMS   ■■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
  
    'Set dbs = DBEngine.Workspaces(0).OpenDatabase(strMdbName, False, False, ";PWD=" & strPw)
  
  
    Dim IDX As Long
    For IDX = 0 To dbs.containers!Forms.Documents.Count - 1
        Set docWork = dbs.containers!Forms.Documents(IDX)

        DoCmd ﾌｫｰﾑを開く docWork.Name, A_DESIGN
      
        Set frm = Forms(docWork.Name)
        'If frm.HasModule Then
        'Set mdl = frm.Module
        Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
        Print #100, "□ Module Name : " & docWork.Name
        Print #100, "□     Created : " & docWork.DateCreated
        Print #100, "□    Modified : " & docWork.LastUpdated
        Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
        Print #100, ""
        'Print #100, mdl.Lines(1, mdl.CountOfLines)
      
        Dim IDX2 As Long
        For IDX2 = 1 To frm.Count
            If Len(RTrim(CStr(frm(IDX2 - 1).RowSource))) > 0 Then
                Print #100, "--------------------"
                Print #100, frm(IDX2 - 1).Name
                Print #100, frm(IDX2 - 1).RowSource
                Print #100, "--------------------"
            End If
        Next
          
          
        'End If
        DoCmd 閉じる a_Form, docWork.Name
    Next

    Print #100, ""
    Print #100, ""
    Print #100, "■■■  REPORTS   ■■■■■■■■■■■■■■■■■■■■■■■■■■■"
    Print #100, ""
    Print #100, ""
  
    Dim IDX3 As Long
    For IDX3 = 0 To dbs.containers!Forms.Documents.Count - 1
        On Error Resume Next
        DoCmd ﾚﾎﾟｰﾄを開く docWork.Name, A_DESIGN
        Set rpt = Reports(docWork.Name)
            'Set mdl = rpt.Module
            Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
            Print #100, "□ Module Name : " & docWork.Name
            Print #100, "□     Created : " & docWork.DateCreated
            Print #100, "□    Modified : " & docWork.LastUpdated
            Print #100, "□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□□"
            Print #100, ""
            Print #100, rpt.RecordSource
        DoCmd 閉じる a_Report, docWork.Name
    Next
  
  
    Close #100
    dbs.Close
    Set dbs = Nothing

End Sub

From Evernote:

[ACCESS→SQLServer]ACCESS内のリンクをVBAではりかえる(DNSver)。

【追記※DNS方式ﾊﾞｰｼﾞｮﾝ】--------------------------------------------

この方法はDNS方式ﾊﾞｰｼﾞｮﾝです。

ローカルＰＣにきちんとODBC設定して行なって使用します。

DNS-LESSﾊﾞｰｼﾞｮﾝはこちら

http://shumitestitblog.blogspot.jp/2012/02/accesssqlserveraccessvba.html

'--------------------------------------------------------

    Dim strDSN As String: strDSN = "systest.aa"

    Dim strDB As String: strDB = "testDB"

    Dim strUser As String: strUser = "user"

    Dim strPass As String: strPass = "pwd"

    Dim TblName As String: TblName = ""

    Dim RemoteTblName As String: RemoteTblName = ""

    '確認(パスワード聞くとかするといいかも)---------------

    rtn = MsgBox("退避ＯＫ？", vbQuestion + vbYesNo, "確認")

    If rtn <> vbYes Then

        Exit Sub

    End If

    

    '実行--------------------------------------

    Dim db As DAO.Database, tb As DAO.TableDef

    Set db = CurrentDb

     For Each tb In db.TableDefs

               

            If tb.Connect <> "" Then 'リンクテーブルだけを処理

                               

                    TblName = tb.Name

                    If Left(tb.Connect, 4) = "Text" Then

                        Dim tmp As String

                        Dim tmp2

                        tmp = tb.SourceTableName

                        tmp2 = split(tmp, ".")

                        RemoteTblName = tmp2(0)

                    Else

                        RemoteTblName = tb.SourceTableName

                    End If

                 

                    '↓チェック=======

                    Dim stADOConnect As String

                    stADOConnect = "Driver={SQL Server};server=" & strDSN & _ 

                                           ";database=" & strDB & _ 

                                           ";uid=" & strUser & ";pwd=" & strPass & ";"

                    Dim ChkFLG As Boolean: ChkFLG = False

                    Dim adoCON As New ADODB.Connection

                    Dim adoRS As ADODB.Recordset

                    Dim mySQL As String

                    adoCON.Open stADOConnect

                    mySQL = "SELECT * FROM dbo.sysobjects " & _ 

                                 " WHERE xtype =N'U' ORDER BY name"

                    Set adoRS = adoCON.Execute(mySQL)

                    Do Until adoRS.EOF = True

                        If RemoteTblName = adoRS!Name Then

                            ChkFLG = True

                            Exit Do

                        End If

                        adoRS.MoveNext

                    Loop

                    adoRS.Close

                    Set adoRS = Nothing

                    adoCON.Close

                    Set adoCON = Nothing

                    '↑チェック=======

                 

                 

                    If ChkFLG = True Then

                        '実行！-----------------------

                        AttachDSNTable TblName, RemoteTblName, strDSN, strDB, strUser, strPass

                    Else

                        'MsgBox("×「" & TblName & "」元の「" & RemoteTblName & _ 

                                    "」テーブルはSQLServerに存在しません。")

                    End If                   

                   

            Else

                'MsgBox ("「" & tb.Name & "」はリンク元なしなのでスルーしました")

            End If

               

    Next tb

   

    RefreshDatabaseWindow

'--------------------------------------------------------

Function AttachDSNTable(stLocalTableName As String, stRemoteTableName As String, stServer As String, stDatabase As String, Optional stUsername As String, Optional stPassword As String)

    On Error GoTo AttachDSNTable_Err

    Dim td As TableDef

    Dim stConnect As String

   

   

    'ここにＯＤＢＣ名

    stConnect = "ODBC;DSN=ここにＯＤＢＣ名;DATABASE=" & stDatabase & ";"

   

   

    '現テーブル削除

    For Each td In CurrentDb.TableDefs

        If td.Name = stLocalTableName Then

            CurrentDb.TableDefs.Delete stLocalTableName

        End If

    Next

    '新テーブル作成

    Set td = CurrentDb.CreateTableDef(stLocalTableName, dbAttachSavePWD, stRemoteTableName, stConnect)

    CurrentDb.TableDefs.Append td

    AttachDSNLessTable = True

       

    Exit Function

AttachDSNTable_Err:

   

    AttachDSNTable = False

    MsgBox "AttachDSNTable encountered an unexpected error: " & Err.Description

End Function

'--------------------------------------------------------

ACCESSからSQLServer 変換　移行　VBA  マクロ