BlogJava-梦幻之旅-随笔分类-VB/VBA/VBS

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 "生成数据表结构共计 " + CStr(count), vbOK+vbInformation, "表"
    x1.Workbooks.Close
    Exit Sub

End Sub

惠万鹏 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 ' 退出新运行的程序
    End If
    Me.Caption = "我的第一个程序"

'以下把程序放入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
'定义鼠标移动到托盘上时显示的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 "请用鼠标右键点击图标!", vbInformation, "实时播音专家"
'单击左键，显示窗体
Timer1.Enabled = False
Call ShowWindow(Me.hWnd, SW_RESTORE)

'下面两句的目的是把窗口显示在窗口最顶层
Me.Show
Me.SetFocus
'' Case WM_RBUTTONUP
''   PopupMenu MenuTray '如果是在系统Tray图标上点右键，则弹出菜单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     '定义一个布尔型变量用于开关作用
    b1 = Not b1
    Timer1.Enabled = b1     '用Timer1来控制图标的闪烁
    If Not b1 Then
        leftBtn.Caption = "开始"
    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图片，为False时为Picture1的图片
  b2 = Not b2
  If b2 Then
        nfIconData.hIcon = Image1.Picture     '托盘图标为Picture2的图片
         infoLabel.Caption = "b"
  Else
        nfIconData.hIcon = Image2.Picture       '托盘图标为Picture1的图片
        infoLabel.Caption = "a"
  End If
   Call Shell_NotifyIcon(NIM_MODIFY, nfIconData)     '修改托盘图标

End Sub

惠万鹏 2013-08-01 11:21 发表评论

VBA 自定义函数

惠万鹏 — Sat, 17 Sep 2011 10:25:00 GMT

惠万鹏 2011-09-17 18:25 发表评论

(原创) VBA 代码的保护

惠万鹏 — Sat, 17 Sep 2011 04:30:00 GMT

1.最简单的方法就是对VBA工程加密
步骤如下:
   1).在VBA工程上左右,会出现如下菜单:

   2)选中VBA项目属性,会弹出如下菜单


2.舍弃或部分舍弃内置VBA代码,改用外置插件,如 DLL,XLA 等代替 VBA.

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

4.总结
   第1种加密码的安全性较低,只能阻挡对程序不太了解的初级用户.
   第2种方法较好,DLL让一般中级程序开发者都有点望而生畏.
   第3这个方法听起来有些玄,搞不好,会让自己电脑中毒, 没有试过.

惠万鹏 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 = "数据源"    '保存数据的Sheet名称
Const strIsqlSheetName = "插入SQL"   '保存SQL的Sheet名称
Const strDeleSheetName = "删除SQL"   '存删除SQL的Sheet名称

Dim strTableName As String           '数据库表名
Dim strTemSql As String              '临时SQL语句
Dim strInsertSql As String           '插入SQL语句

Dim intClumnCount As Integer         '列数
Dim intIndex1 As Integer             '索引变量
Dim intIndex2 As Integer             '第二个索引变量
Dim intIndex3 As Integer             '第三个变量

Rem 激活本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 组装字段头
    For intIndex1 = 1 To intClumnCount
        strTemSql = strTemSql + Worksheets(strDataSheetName).Cells(intHeaderRow, intIndex1).Value
        If intIndex1 < intClumnCount Then
            strTemSql = strTemSql + ","
        End If
    Next intIndex1

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

    Rem 组装SQL语句体
    For intIndex2 = intHeaderRow + 1 To Worksheets(strDataSheetName).UsedRange.Rows.Count
        strInsertSql = strTemSql
        For intIndex3 = 1 To intClumnCount
            Rem 加上单元格里的数据
            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赋值
        Worksheets(strIsqlSheetName).Cells(intIndex2 - intHeaderRow, 1).Value = strInsertSql
    Next intIndex2


    Rem 设置插入SQL的Sheet的样式
    Worksheets(strIsqlSheetName).UsedRange.Select
    With Selection
        .Font.Size = 9                       '设置字号Font.Name = "MS Sans Serif"         '设置字体
        .Font.Color = 1                      '设置字的颜色Borders.LineStyle = xlContinuous    '设置实线边框
        .Columns.AutoFit                     '设置单元格宽度自适应（根据单元格内文字都是自动调节该单元格的宽度）
    End With
    Rem 选中第一个单元格
    Worksheets(strIsqlSheetName).Range("A1").Select


    Rem 删除SQL的Sheet的值
    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 根据类型得到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 如果单元格是其它数据类型
  Else
     tempStr = "'"
     tempStr = tempStr + CStr(c.Value)
     tempStr = tempStr + "'"
  End If

  Rem 返回字符串
  getCellVal = tempStr
End Function

惠万鹏 2011-09-17 00:43 发表评论