梦幻之旅

DEBUG - 天道酬勤
   :: 首页 :: 新随笔 :: 联系 :: 聚合  :: 管理 ::
  671 随笔 :: 6 文章 :: 256 评论 :: 0 Trackbacks
excel2pdm
'******************************************************************************
'* File:     excel2pdm.txt
'* Title:    pdm export to excel
'* Purpose:  To export the tables and columns to Excel
'* Model:    Physical Data Model
'* Objects:  Table, Column, View
'* Author:   ziyan
'* Created:  2012-05-03
'*Modifier:  Hui Wanpeng 2014/07/04
'* Version:  1.0
'******************************************************************************
Option Explicit

Dim md1 'the current model
Set md1=ActiveModel
If(md1 Is Nothing) Then
  MsgBox "There is no Active Model"
End If

Dim HaveExcel
Dim RQ
RQ = vbYes 'MsgBox("Is Excel Installed on your machine?",vbYesNo+vbInformation,"Confirmation")

If RQ=vbYes Then
  HaveExcel=True
  'Open&Create Excel Document
  Dim x1
  set x1=CreateObject("Excel.Application")
  x1.Workbooks.Open "E:/tmp/B超检查表.xls"
  x1.Workbooks(1).Worksheets("Sheet1").Activate
Else
  HaveExcel=False
End If

process x1, md1

sub process(x1,md1)
    dim rwIndex
    dim tableName
    dim colname
    dim table
    dim col
    dim count
    dim dType
    dim nNull

    'on error Resume Next
    For rwIndex =1 To 500 step 1
       With x1.Workbooks(1).Worksheets("Sheet1")
          If .Cells(rwIndex,1).Value="" Then
             Exit For
          End If
          If .Cells(rwIndex,3).Value="" Then
              set table=md1.Tables.CreateNew
              table.Name=.Cells(rwIndex,2).Value
              table.Code=UCase(.Cells(rwIndex,1).Value)
              table.Comment=.Cells(rwIndex,2).Value
              count=count+1
          Else
              colName=.Cells(rwIndex,1).Value
              set col=table.Columns.CreateNew
              
              'MsgBox.Cells(rwIndex,1).Value
               'MsgBox colName,vbOK+vbInformation,"列"
              col.Code=Trim(UCase(.Cells(rwIndex,1).Value))
              col.Name=Trim(UCase( .Cells(rwIndex,1).Value))
              col.Comment=Trim(.Cells(rwIndex,2).Value)
           
              dType=Trim(UCase(.Cells(rwIndex,3).Value))
              'MsgBox Left(dType, 5)
              If Left(dType, 5)="CHAR(" Then
                  dType=Replace(dType,"CHAR","VARCHAR2")
              ElseIf Left(dType, 5)="CAHR(" Then 
                  dType=Replace(dType,"CAHR","VARCHAR2")
              End If
              col.DataType=dType
           
              nNull=Trim(UCase(.Cells(rwIndex,4).Value))
              If nNull="NOT NULL" then
                col.Mandatory="true"
              End If
           
         End If
       End With
    Next

    MsgBox "生成数据表结构共计 " + CStr(count), vbOK+vbInformation, "表"
    x1.Workbooks.Close
    Exit Sub

End Sub


posted on 2014-07-06 21:06 HUIKK 阅读(372) 评论(0)  编辑  收藏 所属分类: VB/VBA/VBS

只有注册用户登录后才能发表评论。
网站导航: