「運命は性格の中にある」
'Win7 Office2003
Option Explicit
Sub main()
Dim objCn As Object
Dim objRs As Object
Dim strConnectionString As String
Dim strDBServ As String
Dim strDBName As String
Dim strDBUser As String
Dim strDBPass As String
Dim strSql As String
Dim i As Integer
Dim j As Integer
Dim strAdr As String
Dim strTxt As String
'On Error GoTo ErrHandler
'接続情報
strDBServ = Range("DBServ").Value
strDBName = Range("DBName").Value
strDBUser = Range("DBUser").Value
strDBPass = Range("DBPass").Value
'メインシート以外削除
If Sheets.Count >= 2 Then
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
End If
'テーブル一覧用のシート追加
Sheets.Add After:=Sheets("ini")
Sheets(ActiveSheet.Name).Name = "一覧"
'タイトル編集
Cells(1, 1).Value = "テーブル名"
Cells(1, 2).Value = "備 考"
'ADOオブジェクト作成
Set objCn = CreateObject("ADODB.Connection")
Set objRs = CreateObject("ADODB.Recordset")
'接続文字列
strConnectionString = "Provider=Sqloledb;Data Source=" & strDBServ & _
";Initial Catalog=" & strDBName & _
";Connect Timeout=15" & ";user id=" & strDBUser & _
";password=" & strDBPass & ""
'接続
objCn.Open strConnectionString
'テーブル一覧作成
strSql = "select t.name from sys.tables t where t.name not like 'SYS%' order by t.name"
'objRs.Open strSql, objCn, adOpenKeyset, adLockReadOnly
objRs.Open strSql, objCn, 1, 1
Range("A2").CopyFromRecordset objRs
'書式設定
Call cellsFix(objRs.RecordCount + 1, objRs.fields.Count + 1)
objRs.Close
'各テーブル毎の定義書作成
i = 2
Do Until Sheets("一覧").Cells(i, 1).Value = ""
Sheets.Add After:=Sheets(ActiveSheet.Name)
Sheets(ActiveSheet.Name).Name = Sheets("一覧").Cells(i, 1).Value
'タイトル編集
Cells(1, 1).Value = "Name"
Cells(1, 2).Value = "Type"
Cells(1, 3).Value = "Len"
Cells(1, 4).Value = "Pre"
Cells(1, 5).Value = "Sca"
strSql = "select c.name,c.system_type_id,c.max_length,c.precision,c.scale from sys.tables t,sys.columns c where t.object_id = c.object_id and t.name = '" & Sheets("一覧").Cells(i, 1).Value & "' order by c.name"
objRs.Open strSql, objCn, 1, 1
j = 2
Do Until objRs.EOF
Cells(j, 1).Value = objRs!Name
Cells(j, 2).Value = getType(objRs!system_type_id)
Cells(j, 3).Value = objRs!max_length
Cells(j, 4).Value = objRs!precision
Cells(j, 5).Value = objRs!scale
j = j + 1
objRs.MoveNext
Loop
'書式設定
Call cellsFix(objRs.RecordCount + 1, objRs.fields.Count)
objRs.Close
i = i + 1
Loop
'リンク作成
Sheets("一覧").Select
i = 2
Do Until Cells(i, 1).Value = ""
Cells(i, 1).Select
strAdr = Cells(i, 1).Value & "!A1"
strTxt = Cells(i, 1).Value
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=strAdr, TextToDisplay:=strTxt
i = i + 1
Loop
Cells(1, 1).Select
Sheets("ini").Select
Cells(1, 1).Select
ExitSub:
'objRs.State
'0 adStateClosed 閉じている '1 adStateOpen オープン
'2 adStateConnecting 接続中 '4 adStateExecuting 実行中
'8 adStateFetching 行を取得
If Not objRs Is Nothing Then
If objRs.State = 1 Then
objRs.Close
End If
Set objRs = Nothing
End If
If Not objCn Is Nothing Then
If objCn.State = 1 Then
objCn.Close
End If
Set objCn = Nothing
End If
MsgBox "(。・_・。)ノ"
Exit Sub
ErrHandler:
'エラー処理
MsgBox ("Error No =" & Err.Number & vbCr & "Error Msg=" & Err.Description)
Resume ExitSub
End Sub
Function getType(intParm As Integer) As String
getType = ""
Select Case intParm
Case 175
getType = "char"
Case 167
getType = "varchar"
Case 40
getType = "date"
Case 61
getType = "datetime"
Case 106
getType = "decimal"
Case 62
getType = "float"
Case 56
getType = "int"
Case 239
getType = "nchar"
Case 108
getType = "numeric"
Case 231
getType = "nvarchar"
Case 52
getType = "smalint"
Case Else
getType = intParm & ":未対応"
End Select
End Function
Function cellsFix(lngRow As Long, lngCol As Long)
Cells.Select
Cells.EntireColumn.AutoFit
Range(Cells(1, 1), Cells(lngRow, lngCol)).Select
Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
Selection.Borders(xlEdgeTop).LineStyle = xlContinuous
Selection.Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Borders(xlEdgeRight).LineStyle = xlContinuous
Selection.Borders(xlInsideVertical).LineStyle = xlContinuous
Selection.Borders(xlInsideHorizontal).LineStyle = xlContinuous
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$1"
.LeftFooter = "&A"
.CenterFooter = "&P / &N"
.RightFooter = "&F"
' .LeftMargin = Application.InchesToPoints(0.393700787401575)
' .RightMargin = Application.InchesToPoints(0.393700787401575)
' .TopMargin = Application.InchesToPoints(0.78740157480315)
' .BottomMargin = Application.InchesToPoints(0.393700787401575)
' .HeaderMargin = Application.InchesToPoints(0.393700787401575)
' .FooterMargin = Application.InchesToPoints(0.196850393700787)
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = -3
' .CenterHorizontally = False
' .CenterVertically = False
' .Orientation = xlPortrait
' .Draft = False
' .PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 100
' .PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SplitRow = 0.777777777777778
ActiveWindow.FreezePanes = True
Range(Cells(1, 1), Cells(1, lngCol)).Select
Selection.Interior.ColorIndex = 35
Cells(1, 1).Select
End Function