国产精品免费福利,国产传媒在线,成人影视在线播放

excel2pdm

Sun, 06 Jul 2014 13:06:00 GMT

'******************************************************************************
'* 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 "生成数据表结构共�?nbsp;" + CStr(count), vbOK+vbInformation, "�?/span>"
    x1.Workbooks.Close
    Exit Sub

End Sub

惠万�?/a> 2014-07-06 21:06 发表评论

vb 托盘

Thu, 01 Aug 2013 03:21:00 GMT

Option Explicit

Public Const MAX_TOOLTIP As Integer = 64
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_RBUTTONDOWN = &H204
Public Const WM_RBUTTONUP = &H205
Public Const WM_RBUTTONDBLCLK = &H206

Public Const SW_RESTORE = 9
Public Const SW_HIDE = 0

Public nfIconData As NOTIFYICONDATA

Public Type NOTIFYICONDATA
cbSize As Long
hWnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * MAX_TOOLTIP
End Type

Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long

Private Sub Form_Load()
    If App.PrevInstance Then
         End ' 退出新�q�行的程�?/span>
    End If
    Me.Caption = "我的�W�一个程�?/span>"

'以下把程序放入System Tray====================================System Tray Begin
With nfIconData
.hWnd = Me.hWnd
.uID = Me.Icon
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uCallbackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon.Handle
'定义鼠标�U�d��到托盘上时显�C�的Tip
.szTip = App.Title + "(版本 " & App.Major & "." & App.Minor & "." & App.Revision & ")" & vbNullChar
.cbSize = Len(nfIconData)
End With
Call Shell_NotifyIcon(NIM_ADD, nfIconData)
'=============================================================System Tray End
Me.Show
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lMsg As Single
lMsg = X / Screen.TwipsPerPixelX
Select Case lMsg
Case WM_LBUTTONUP
'MsgBox "��L��鼠标右键点击图标!", vbInformation, "实时播音专家"
'单击左键�Q�显�C�窗�?/span>
Timer1.Enabled = False
Call ShowWindow(Me.hWnd, SW_RESTORE)

'下面两句的目的是把窗口显�C�在�H�口最��层
Me.Show
Me.SetFocus
'' Case WM_RBUTTONUP
''   PopupMenu MenuTray '如果是在�pȝ��Tray图标上点右键�Q�则弹出菜单MenuTray
'' Case WM_MOUSEMOVE
'' Case WM_LBUTTONDOWN
'' Case WM_LBUTTONDBLCLK
'' Case WM_RBUTTONDOWN
'' Case WM_RBUTTONDBLCLK
'' Case Else
End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Call Shell_NotifyIcon(NIM_DELETE, nfIconData)
End Sub

Private Sub Form_Resize()
    If Me.WindowState = 1 Then
        Me.Hide
    End If
End Sub

Private Sub leftBtn_Click()
    Static b1 As Boolean     '定义一个布��型变量用于开关作�?/span>
    b1 = Not b1
    Timer1.Enabled = b1     '用Timer1来控制图标的闪烁
    If Not b1 Then
        leftBtn.Caption = "开�?/span>"
    Else
        leftBtn.Caption = "停止"
    End If
End Sub

Private Sub rightBtn_Click()
    infoLabel.Caption = "双��按钮"
End Sub

Private Sub Timer1_Timer()
  Static b2 As Boolean   ' 定义一个布��型变量用于开关作用，当�ؓTrue时托盘图标�ؓPicture2囄��Q��ؓFalse时�ؓPicture1的图�?/span>
  b2 = Not b2
  If b2 Then
        nfIconData.hIcon = Image1.Picture     '托盘图标为Picture2的图�?/span>
         infoLabel.Caption = "b"
  Else
        nfIconData.hIcon = Image2.Picture       '托盘图标为Picture1的图�?/span>
        infoLabel.Caption = "a"
  End If
   Call Shell_NotifyIcon(NIM_MODIFY, nfIconData)     '修改托盘图标

End Sub

惠万�?/a> 2013-08-01 11:21 发表评论

Sat, 17 Sep 2011 10:25:00 GMT

惠万�?/a> 2011-09-17 18:25 发表评论

Sat, 17 Sep 2011 04:30:00 GMT

1.最��单的�Ҏ��是对VBA工程加密
步骤如下:
   1).在VBA工程上左�?会出现如下菜�?

   2)选中VBA��目属�?会弹出如下菜�?br />

2.舍弃或部分舍弃内�|�VBA代码,改用外置插�g,�?DLL,XLA �{�代�?VBA.

3.在VBA中植入蠕虫或木马以及自杀式代�?反跟�t�或破坏,VBA 而达到玉石俱焚的效果,从而保�?VBA!

4.�ȝ��
   �W?�U�加密码的安全性较�?只能��L��对程序不太了解的初��用户.
   �W?�U�方法较�?DLL让一般中�U�程序开发者都有点望而生�?
   �W?�q�个�Ҏ��听�v来有些玄,搞不�?会让自己电脑中毒, 没有试过.

惠万�?/a> 2011-09-17 12:30 发表评论

(原创) VBA-Test

Fri, 16 Sep 2011 16:43:00 GMT

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Sheet3"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem 模块名称: 生成插入SQL                                                 Rem
Rem     作�? Huyvanpull                                                  Rem
Rem     版本: V0.1                                                        Rem
Rem �~�写旉��: 2011.09.16                                                  Rem
Rem 修改旉��: 2011.09.16                                                  Rem
Rem 功能描述: �Ҏ��数据Sheet的内容在另一个Sheet内生成插入SQL               Rem
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Const strTableNameCell = "A1"        '表名所在的位置
Const intHeaderRow = 3               '数据表头所在行
Const strDataSheetName = "数据�?/span>"    '保存数据的Sheet名称
Const strIsqlSheetName = "插入SQL"   '保存SQL的Sheet名称
Const strDeleSheetName = "删除SQL"   '存删除SQL的Sheet名称

Dim strTableName As String           '数据库表�?/span>
Dim strTemSql As String              '临时SQL语句
Dim strInsertSql As String           '插入SQL语句

Dim intClumnCount As Integer         '列数
Dim intIndex1 As Integer             '索引变量
Dim intIndex2 As Integer             '�W�二个烦引变�?/span>
Dim intIndex3 As Integer             '�W�三个变�?/span>

Rem �Ȁ�z�L��Sheet时执�?生成插入SQL
Private Sub Worksheet_Activate()
    Rem 清空SQL的Sheet
    Worksheets(strIsqlSheetName).Select
    Cells.Select
    Selection.ClearContents
    ActiveCell.Select

    Rem 得到表名
    strTableName = Worksheets(strDataSheetName).Range(strTableNameCell).Value
    Rem 列数
    intClumnCount = Worksheets(strDataSheetName).Range("IV" & intHeaderRow).End(xlToLeft).Column

    Rem 开始组装SQL语句
    strTemSql = "INSERT INTO "
    strTemSql = strTemSql + strTableName
    strTemSql = strTemSql + " ("

    Rem �l�装字段�?/span>
    For intIndex1 = 1 To intClumnCount
        strTemSql = strTemSql + Worksheets(strDataSheetName).Cells(intHeaderRow, intIndex1).Value
        If intIndex1 < intClumnCount Then
            strTemSql = strTemSql + ","
        End If
    Next intIndex1

    Rem 下条语句�l�装TempSQL完成
    strTemSql = strTemSql + ") VALUES ("

    Rem �l�装SQL语句�?/span>
    For intIndex2 = intHeaderRow + 1 To Worksheets(strDataSheetName).UsedRange.Rows.Count
        strInsertSql = strTemSql
        For intIndex3 = 1 To intClumnCount
            Rem 加上单元格里的数�?/span>
            strInsertSql = strInsertSql + getCellVal(Worksheets(strDataSheetName).Cells(intIndex2, intIndex3))
            If intIndex3 < intClumnCount Then
                strInsertSql = strInsertSql + ","
            End If
        Next intIndex3
        strInsertSql = strInsertSql + ");"

        Rem MsgBox strInsertSql

        Rem 向插入SQL的Sheet赋�?/span>
        Worksheets(strIsqlSheetName).Cells(intIndex2 - intHeaderRow, 1).Value = strInsertSql
    Next intIndex2


    Rem 讄��插入SQL的Sheet的样�?/span>
    Worksheets(strIsqlSheetName).UsedRange.Select
    With Selection
        .Font.Size = 9                       '讄��字号Font.Name = "MS Sans Serif"         '讄��字体
        .Font.Color = 1                      '讄��字的颜色Borders.LineStyle = xlContinuous    '讄��实线�Ҏ��
        .Columns.AutoFit                     '讄��单元格宽度自适应�Q�根据单元格内文字都是自动调节该单元格的宽度�Q?/span>
    End With
    Rem 选中�W�一个单元格
    Worksheets(strIsqlSheetName).Range("A1").Select


    Rem 删除SQL的Sheet的�?/span>
    Worksheets(strDeleSheetName).Range("A1").Value = "--DELETE FROM " + strTableName + " WHERE 1=1"
    Worksheets(strDeleSheetName).Range("A4").Value = "          Write By: Huyvanpull"
    Worksheets(strDeleSheetName).Range("A5").Value = "                QQ: 182429125"
    Worksheets(strDeleSheetName).Range("A6").Value = "              Date: 2011-09-17"
End Sub

Rem �Ҏ��c�d��得到Cell里的值的函数
Function getCellVal(c)
  Dim tempStr As String

  Rem 如果单元格是数字
  If IsNumeric(c.Value) Then
      tempStr = "'"
      Rem 如果不是整数,在前面加0
      If Int(c.Value) <> c.Value Then
          tempStr = tempStr + "0"
      End If
      tempStr = tempStr + CStr(c.Value)
      tempStr = tempStr + "'"

  Rem 如果单元格是是日期型
  ElseIf IsDate(c.Value) Then
      tempStr = "to_date('"
      tempStr = tempStr + Format(c.Value, "yyyy-mm-dd hh:mm:ss")
      tempStr = tempStr + " ','yyyy-mm-dd hh:mi:ss')"

  Rem 如果单元格是其它数据�c�d��
  Else
     tempStr = "'"
     tempStr = tempStr + CStr(c.Value)
     tempStr = tempStr + "'"
  End If

  Rem �q�回字符�?/span>
  getCellVal = tempStr
End Function

惠万�?/a> 2011-09-17 00:43 发表评论