VB程序员博客

创建可输出的Dll文件
我一个函数要引用其他函数时用这样的方式
Public Function a()
~~~~
end Function

Public Function b()
~~~~
end Function
Public Function c()
~~~~
end Function
用LINK.exe编译时出错
LINK2:warning LNK4044:unrecognized option "VERS"; ignored
Pro.obj:warning LNK4044:export of symbol "DllUnregisterServer" should be PRIVATE
Pro.obj:warning LNK4044:export of symbol "DllGetClassObject" should be PRIVATE
Pro.obj:warning LNK4044:export of symbol "DllRegisterServer" should be PRIVATE
Pro.obj:warning LNK4044:export of symbol "DllCanUnloadNow" should be PRIVATE
Pro.obj:warning LNK4044:unresolved external symbol mathadd
e:vbllPro.lib : fatal error LNK1120:1 unresolved externals
LINK2:fatal error LNK1141:failure during build of exports file

最好不要使用VB做这些鸡肋的东西函数要返回值,不返回的改为sub过程

总是有人问这些问题，这些问题问楼上这位兄弟就可以了。

比如我用CreateCompatibleDC、CreateCompatibleBitmap创建了一个600X400的兼容内存设备上下文环境，然后用RoundRect在上面依这个位图的大小绘制一圆角矩形，最后再用BitBlt把这幅位图复制到窗体上。可是我发现窗体上的圆角矩形的四个圆角外面会有设备上下文环境的黑色背景。请问这个怎样去除呢？

非常感谢，我用CreateRoundRectRgn和FillRgn搞定了！

vb程序中动态创建工程没引用的vb自定义控件,但是创建起来的控件却没有UserControl中的自定义属性.
创建语句:
licenses.add "prjUC_Text.UC_Text"
me.controls.add "prjUC_Text.UC_Text","ucTest",frame控件名自定义控件主体代码是否已在工程里<
有点点麻烦，建议最好现在窗体上先添加这种控件的一个实例，接着再用load语句，加载更多的这种控件，这样就可以避开控件许可证问题哦<
up…

<

想自动创建QQ的快捷启动，需要带参数，网上提供了一种
Option   Explicit
Public   Sub   mShellLnk(ByVal   LnkName   As   String,   IconFileIconIndex   As   String,   ByVal   FilePath   As   String,   Optional   ByVal   FileName   As   String,   Optional   ByVal   HookKey   As   String   =   " ",   Optional   ByVal   StrRemark   As   String   =   " ",   Optional   ByVal   strDesktop   As   String   =   " ")
Dim   WshShell   As   Object,   WScript   As   Object,   oShellLink   As   Object
                  Set   WshShell   =   CreateObject( "WScript.Shell ")
                  If   strDesktop   =   " "   Then   strDesktop   =   WshShell.SpecialFolders( "Desktop ")       '桌面路径
                  If   UCase(Right(LnkName,   4))   =   ".LNK "   Then
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName)     '创建快捷方式,参数为路径和名称
                  Else
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName   &   ".lnk ")
                  End   If
                  oShellLink.TargetPath   =   FilePath   &   " "   &   FileName
                  oShellLink.WindowStyle   =   1   '风格
                  oShellLink.Hotkey   =   HookKey   '热键
                  oShellLink.IconLocation   =   IconFileIconIndex   '图标
                  oShellLink.Description   =   StrRemark   '快捷方式备注内容
                  oShellLink.WorkingDirectory   =   FilePath   '源文件所在目录
                  oShellLink.Save         '保存创建的快捷方式
                  Set   WshShell   =   Nothing
                  Set   oShellLink   =   Nothing
End   Sub
的方法，可是这个方法，我做不到带参数。

谁有别的方法做一个带参数快捷方式的方法呢？
只要成功，就全给分…………………………..看了一下这个WshShortcut对象,它有一个叫 "Arguments "的属性……

于是给你小改了一下:

Public   Sub   mShellLnk(ByVal   LnkName   As   String,   IconFileIconIndex   As   String,   ByVal   FilePath   As   String,   Optional   ByVal   FileName   As   String,   Optional   ByVal   StrArg   As   String,   Optional   ByVal   HookKey   As   String   =   " ",   Optional   ByVal   StrRemark   As   String   =   " ",   Optional   ByVal   strDesktop   As   String   =   " ")
Dim   WshShell   As   Object,   WScript   As   Object,   oShellLink   As   Object
                  Set   WshShell   =   CreateObject( "WScript.Shell ")
                  If   strDesktop   =   " "   Then   strDesktop   =   WshShell.SpecialFolders( "Desktop ")       '桌面路径
                  If   UCase(Right(LnkName,   4))   =   ".LNK "   Then
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName)     '创建快捷方式,参数为路径和名称
                  Else
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName   &   ".lnk ")
                  End   If
                  oShellLink.TargetPath   =   FilePath   &   " "   &   FileName
                  oShellLink.Arguments   =   StrArg
                  oShellLink.WindowStyle   =   1   '风格
                  oShellLink.Hotkey   =   HookKey   '热键
                  oShellLink.IconLocation   =   IconFileIconIndex   '图标
                  oShellLink.Description   =   StrRemark   '快捷方式备注内容
                  oShellLink.WorkingDirectory   =   FilePath   '源文件所在目录
                  oShellLink.Save         '保存创建的快捷方式
                  Set   WshShell   =   Nothing
                  Set   oShellLink   =   Nothing
End   Sub

例子:

mShellLnk   "TestLnk ", "notepad.exe ", "C:windows ",   "notepad.exe ",   "test.txt "

PS:

其实LZ自己看一下,也会发现啊,也就那么几个成员….提示 ActiveX部件不能创建对象"WScript.Shell"
怎么解决啊?
还是老马人最好，又帮了我一个忙，我就改为用VBS了，还真方便，谢谢

cmd = "D: est.exe"
Set objShell = CreateObject("Wscript.Shell")
Set objShellLink = objShell.CreateShortcut("测试快捷方式.lnk")
objShellLink.TargetPath = cmd
objShellLink.Arguments = "备注内容"
objShellLink.Save

把以上代码写进记事本，保存名为*.vbs运行，就可看到效果了，再一次谢谢老马………….老马你真厉害啊 我找了半天都没找到 你看的英文？ ，命令行注释 你怎么知道就是添加在目标之后的？？？

想自动创建QQ的快捷启动，需要带参数，网上提供了一种
Option   Explicit
Public   Sub   mShellLnk(ByVal   LnkName   As   String,   IconFileIconIndex   As   String,   ByVal   FilePath   As   String,   Optional   ByVal   FileName   As   String,   Optional   ByVal   HookKey   As   String   =   " ",   Optional   ByVal   StrRemark   As   String   =   " ",   Optional   ByVal   strDesktop   As   String   =   " ")
Dim   WshShell   As   Object,   WScript   As   Object,   oShellLink   As   Object
                  Set   WshShell   =   CreateObject( "WScript.Shell ")
                  If   strDesktop   =   " "   Then   strDesktop   =   WshShell.SpecialFolders( "Desktop ")       '桌面路径
                  If   UCase(Right(LnkName,   4))   =   ".LNK "   Then
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName)     '创建快捷方式,参数为路径和名称
                  Else
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName   &   ".lnk ")
                  End   If
                  oShellLink.TargetPath   =   FilePath   &   " "   &   FileName
                  oShellLink.WindowStyle   =   1   '风格
                  oShellLink.Hotkey   =   HookKey   '热键
                  oShellLink.IconLocation   =   IconFileIconIndex   '图标
                  oShellLink.Description   =   StrRemark   '快捷方式备注内容
                  oShellLink.WorkingDirectory   =   FilePath   '源文件所在目录
                  oShellLink.Save         '保存创建的快捷方式
                  Set   WshShell   =   Nothing
                  Set   oShellLink   =   Nothing
End   Sub
的方法，可是这个方法，我做不到带参数。

谁有别的方法做一个带参数快捷方式的方法呢？
只要成功，就全给分…………………………..看了一下这个WshShortcut对象,它有一个叫 "Arguments "的属性……

于是给你小改了一下:

Public   Sub   mShellLnk(ByVal   LnkName   As   String,   IconFileIconIndex   As   String,   ByVal   FilePath   As   String,   Optional   ByVal   FileName   As   String,   Optional   ByVal   StrArg   As   String,   Optional   ByVal   HookKey   As   String   =   " ",   Optional   ByVal   StrRemark   As   String   =   " ",   Optional   ByVal   strDesktop   As   String   =   " ")
Dim   WshShell   As   Object,   WScript   As   Object,   oShellLink   As   Object
                  Set   WshShell   =   CreateObject( "WScript.Shell ")
                  If   strDesktop   =   " "   Then   strDesktop   =   WshShell.SpecialFolders( "Desktop ")       '桌面路径
                  If   UCase(Right(LnkName,   4))   =   ".LNK "   Then
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName)     '创建快捷方式,参数为路径和名称
                  Else
                        Set   oShellLink   =   WshShell.CreateShortcut(strDesktop   &   " "   &   LnkName   &   ".lnk ")
                  End   If
                  oShellLink.TargetPath   =   FilePath   &   " "   &   FileName
                  oShellLink.Arguments   =   StrArg
                  oShellLink.WindowStyle   =   1   '风格
                  oShellLink.Hotkey   =   HookKey   '热键
                  oShellLink.IconLocation   =   IconFileIconIndex   '图标
                  oShellLink.Description   =   StrRemark   '快捷方式备注内容
                  oShellLink.WorkingDirectory   =   FilePath   '源文件所在目录
                  oShellLink.Save         '保存创建的快捷方式
                  Set   WshShell   =   Nothing
                  Set   oShellLink   =   Nothing
End   Sub

例子:

mShellLnk   "TestLnk ", "notepad.exe ", "C:windows ",   "notepad.exe ",   "test.txt "

PS:

其实LZ自己看一下,也会发现啊,也就那么几个成员….提示 ActiveX部件不能创建对象"WScript.Shell"
怎么解决啊?
还是老马人最好，又帮了我一个忙，我就改为用VBS了，还真方便，谢谢

cmd = "D: est.exe"
Set objShell = CreateObject("Wscript.Shell")
Set objShellLink = objShell.CreateShortcut("测试快捷方式.lnk")
objShellLink.TargetPath = cmd
objShellLink.Arguments = "备注内容"
objShellLink.Save

把以上代码写进记事本，保存名为*.vbs运行，就可看到效果了，再一次谢谢老马………….老马你真厉害啊 我找了半天都没找到 你看的英文？ ，命令行注释 你怎么知道就是添加在目标之后的？？？

引用一个类模块时提示:
activex 部件不能创建对象
怎么解决啊?看看类模块引用的activex 部件有没有注册啊~~<
http://download.csdn.net/source/1627047在运行中

regsvr32 文件名称

如

regsvr32 c:windowssystem32a.dll<

引用一个类模块时提示:
activex 部件不能创建对象
怎么解决啊?看看类模块引用的activex 部件有没有注册啊~~<
http://download.csdn.net/source/1627047在运行中

regsvr32 文件名称

如

regsvr32 c:windowssystem32a.dll<

怎么创建一个文件夹这样的( c:123…..100 ) 谁能给我个代码看看

<
Option Explicit
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long

Private Sub Command1_Click()
  MakeSureDirectoryPathExists "c:123456789"
  MsgBox "建立完成!"
End Sub

没有错误，能马上运行的！

我们所谓的动态创建数据库，在ＳＱＬ　ＳＥＲＶＥＲ里是不是必须要有这么一个总的全面的数据库？然后通过ＡＤＯ调用，再创建出自己需要的数据库啊！

只要你拥有SQL的超级用户权限，就可以通过ADO调用，在服务器中创建数据库。

一般是先利用SQL企业管理器创建库名及用户名、密码，
然后才从应用程序里的ADO动态地创建表以及表内、表间其他数据对象

Option Explicit

Private hMainMenu As Long                                '主菜单
Private hFirstLevelMenu() As Long                        '一级菜单
Private hSecondLevelMenu As Long                          '二级菜单
Private hThirdLevelMenu As Long                          '三级菜单

Private intMenuCount As Integer                          '菜单总数
Private arrMenuList() As String                      '菜单信息列表数组
Private lngWinProc As Long

Private Const MF_POPUP = &H10
Private Const MF_STRING = &H0
Private Const MF_SEPARATOR = &H800
Private Const MF_BYPOSITION = &H400

Private Const WM_COMMAND = &H111
Private Const GWL_WNDPROC = (-4)

Public Xwx As New Class1
Public R1 As Recordset

'创建菜单API函数
Private Declare Function CreateMenu Lib "User32" () As Long

'创建弹出式菜单API函数
Private Declare Function CreatePopupMenu Lib "User32" () As Long

'插入菜单项API函数
Private Declare Function InsertMenu Lib "User32" Alias "InsertMenuA" _
    (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
 
'追加菜单项API函数
Private Declare Function AppendMenu Lib "User32" Alias "AppendMenuA" _
    (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
 
'修改菜单项API函数
Private Declare Function ModifyMenu Lib "User32" Alias "ModifyMenuA" _
    (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As Any) As Long

'设定菜单到对象上API函数
Private Declare Function SetMenu Lib "User32" (ByVal hwnd As Long, ByVal hMenu As Long) As Long

'在对象上画菜单条API函数
Private Declare Function DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long

'获取一个窗口的菜单句柄
Private Declare Function GetMenu Lib "User32" (ByVal hwnd As Long) As Long

'获取子菜单句柄
Private Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long

'删除菜单控件, 释放资源
Private Declare Function DestroyMenu Lib "User32" (ByVal hMenu As Long) As Long

'在窗口结构中为指定的窗口设置信息
Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" _
    (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'从指定窗口的结构中获得信息
Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

'调用窗口事件处理
Private Declare Function CallWindowProc Lib "User32" Alias "CallWindowProcA" _
    (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Sub main()

Form1.Show

End Sub

'自动创建菜单过程
Public Sub AutoCreateMenu(frmName As Form)
    Dim i As Integer, j As Integer, k As Integer, intTopMenuCount As Integer
    Dim wFlags As Long
 
    '建立主菜单
    hMainMenu = GetMenu(frmName.hwnd)
    If hMainMenu = 0 Then Exit Sub
 
    '从数据库菜单表中取出信息初始化菜单数组
    Call InitMenuArray
    ReDim hFirstLevelMenu(intMenuCount)
 
    '建立一级菜单  TODO 循环优化
    For i = 1 To intMenuCount
        If arrMenuList(3, i) = "1" Then
            '取得一个弹出式菜单的句柄。
            hFirstLevelMenu(i) = CreatePopupMenu()
   
            '为主菜单添加菜单项及添加Caption属性并指定为弹出式菜单属性。
            AppendMenu hMainMenu, MF_POPUP Or MF_BYPOSITION Or MF_STRING, hFirstLevelMenu(i), arrMenuList(2, i)
            intTopMenuCount = intTopMenuCount + 1
        End If
    Next i
 
    '建立二级菜单
    For i = 1 To intMenuCount
        If arrMenuList(3, i) = "2" Then
            If arrMenuList(2, i) = "-" Then
                wFlags = MF_SEPARATOR Or MF_BYPOSITION
            Else
                wFlags = MF_STRING Or MF_BYPOSITION
            End If
         
            For j = 1 To intMenuCount
                If arrMenuList(5, i) = arrMenuList(1, j) Then                  'i循环菜单的上级菜单编号=j循环菜单的菜单编号
                    hSecondLevelMenu = GetSubMenu(hMainMenu, arrMenuList(4, j))
                 
                    '建立三级菜单
                    If arrMenuList(6, i) = "0" Then                            'END_MENU_FLAG=0 表示还有下属子菜单
                        '取得一个弹出式菜单的句柄。
                        hThirdLevelMenu = CreatePopupMenu()
                        For k = 1 To intMenuCount
                            If arrMenuList(5, k) = arrMenuList(1, i) Then      'k循环菜单的上级菜单编号=i循环菜单的菜单编号
                                AppendMenu hThirdLevelMenu, wFlags, arrMenuList(1, k), arrMenuList(2, k)
                            End If
                        Next k
                     
                        AppendMenu hSecondLevelMenu, wFlags Or MF_POPUP, hThirdLevelMenu, arrMenuList(2, i)
                    Else
                        AppendMenu hSecondLevelMenu, wFlags, arrMenuList(1, i), arrMenuList(2, i)
                    End If
                End If
            Next j
        End If
    Next i
 
    '将主菜单设置给本窗口。
    SetMenu frmName.hwnd, hMainMenu
 
    '响应API创建成的菜单单击事件
    lngWinProc = GetWindowLong(frmName.hwnd, GWL_WNDPROC)
    'SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
   
    SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu
   
   
End Sub

'响应API创建成的菜单单击事件
Private Function ClickMenu(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case wMsg
        Case WM_COMMAND
            Select Case wParam
                Case 900204
                    frmSysUser.Show
                Case 900205
                    frmSysRole.Show
                Case 900210
                    Unload frmMain
            End Select
    End Select
 
    ClickMenu = CallWindowProc(lngWinProc, hwnd, wMsg, wParam, lParam)
End Function

'获取系统菜单总个数
Private Function GetMenuCount() As Integer
    Dim rsMenu As New ADODB.Recordset
   
    Dim gsSql As String
   
 
    gsSql = "SELECT COUNT(*) CNT FROM SYS_MENU"
    If DBQuerySQL(rsMenu, gsSql) = 1 Then
        GetMenuCount = rsMenu("CNT").Value
    Else
        GetMenuCount = 0
    End If
   
    rsMenu.Close
End Function

'菜单数组赋值
  Function InitMenuArray()
    Dim i As Integer
    Dim rsMenu As New ADODB.Recordset
    Dim gsSql  As String
   

    'MenuArray数组描述
    '第一维按顺序分别存放 菜单编号、菜单名称、菜单层级、菜单显示顺序、上级菜单、是否末级菜单、菜单对应窗体名、菜单操作权限
    intMenuCount = GetMenuCount()
   
    ReDim arrMenuList(1 To 8, 1 To intMenuCount)
 
    'gsSql = "SELECT " & _
            "MENU_NO," & _
            "MENU_NAME," & _
            "MENU_LEVEL," & _
            "MENU_SEQ," & _
            "PARENT_MENU," & _
            "END_MENU_FLAG," & _
            "EXEC_FORM," & _
            "'1' MENU_PVG" & _
            "  FROM SYS_MENU " & _
            " ORDER BY MENU_NO,MENU_SEQ"
           
    gsSql = "SELECT " & _
            "sys_MENU_1," & _
            "sys_MENU_2," & _
            "sys_MENU_3," & _
            "sys_MENU_4," & _
            "sys_MENU_5," & _
            "sys_MENU_6," & _
            "sys_MENU_7," & _
            "'0' sys_MENU_8" & _
            "  FROM SYS_MENU " & _
            " ORDER BY sys_MENU_1,sys_MENU_4"
           
           
    If DBQuerySQL(rsMenu, gsSql) <> -1 Then
        For i = 1 To rsMenu.RecordCount
            arrMenuList(1, i) = rsMenu("sys_MENU_1").Value
            arrMenuList(2, i) = rsMenu("sys_MENU_2").Value
            arrMenuList(3, i) = rsMenu("sys_MENU_3").Value
            arrMenuList(4, i) = rsMenu("sys_MENU_4").Value
            arrMenuList(5, i) = rsMenu("sys_MENU_5").Value
            arrMenuList(6, i) = rsMenu("sys_MENU_6").Value
            arrMenuList(7, i) = rsMenu("sys_MENU_7").Value
            arrMenuList(8, i) = rsMenu("sys_MENU_8").Value
         
            rsMenu.MoveNext
        Next i
    End If
    rsMenu.Close
   
End Function

那位老师可以决绝这个，问题

程序运行到：
    SetWindowLong frmName.hwnd, GWL_WNDPROC, AddressOf ClickMenu

vb就自动关闭了，不知道问题出在哪儿，在线求助！

问题已近解决，明天结贴，谢谢各位。

ClickMenu参数问题？

还是有问题，

Case WM_COMMAND
            Select Case wParam
                Case 900204
                  ‘’ frmSysUser.Show
                Case 900205
                  ‘’ frmSysRole.Show
                Case 900210
                  ‘’ Unload frmMain
            End Select

单引号后面不用就可以，去掉单引号就自动退出VB

人呢？

问题解决，是参数回调错误。