VB6 结构是否可以作为自定义函数的参数

MeBoss 2011-09-14 05:42:36

如题，如果可以的话，能否给下code，3Q

...全文

238 13 打赏收藏转发到动态举报

写回复

用AI写文章

13 条回复

切换为时间正序

请发表友善的回复…

发表回复

无·法 2011-09-15

打赏
举报

[Quote=引用 3 楼 meboss 的回复:]

不是吧有怎么麻烦吗
这是模块代码
Public Type a
i As Integer
B As String
c As Single
d As Double
e As Long
f As Byte
asd(2) As Double
End Type

这是窗体里面的代码：
Public Sub abc(c As a)

MsgBox c.c
End Sub

我这样编译都无法通过，请问有什么解决方案吗
[/Quote]这个问题我很久以前也遇到过，没找到办法解决，最后将c As a做为全局变量才解决。需要用到c那么就在调用函数前将c赋值改变下。

无·法 2011-09-15

打赏
举报

1楼的太狠了

MeBoss 2011-09-15

打赏
举报

不是吧有怎么麻烦吗
这是模块代码
Public Type a
i As Integer
B As String
c As Single
d As Double
e As Long
f As Byte
asd(2) As Double
End Type

这是窗体里面的代码：
Public Sub abc(c As a)

MsgBox c.c
End Sub

我这样编译都无法通过，请问有什么解决方案吗

MeBoss 2011-09-15

打赏
举报

[Quote=引用 10 楼 sysdzw 的回复:]

引用 9 楼 meboss 的回复:

引用 5 楼 sysdzw 的回复:

引用 3 楼 meboss 的回复:

不是吧有怎么麻烦吗
这是模块代码
Public Type a
i As Integer
B As String
c As Single
d As Double
e As Long
f As Byte
asd(2) As Double
End Ty……
[/Quote]

呵呵 friend 是可以的，不过我要放在标准模块中，所以就会保存，因为 friend是不能放在标准模块中的，哎VB6有时候用着确实蛋疼

MeBoss 2011-09-15

打赏
举报

[Quote=引用 11 楼 worldy 的回复:]

VB UDT（Type定义类型）如果是窗口，模块，私有类模块、私有的控件中定义者，不能作为公共函数的参数或返回值
只有在定义为Public的类模块或控件中（注意不是类模块中定义Public成员。）则可以作为参数或返回值。
不幸的是，在工程中直接添加的类，都只能是私有属性。

如果希望UDT能够作为参数传递，则要创建一个独立的OCX工程或者Activex.dll或者Activex.exe ……
[/Quote]

学习了，原来VB6原来还是可以传结构的，不过太麻烦了。3Q

worldy 2011-09-15

打赏
举报

VB UDT（Type定义类型）如果是窗口，模块，私有类模块、私有的控件中定义者，不能作为公共函数的参数或返回值
只有在定义为Public的类模块或控件中（注意不是类模块中定义Public成员。）则可以作为参数或返回值。
不幸的是，在工程中直接添加的类，都只能是私有属性。

如果希望UDT能够作为参数传递，则要创建一个独立的OCX工程或者Activex.dll或者Activex.exe 工程，并在一个公有的类模块或OCX模块中定义UDT。

无·法 2011-09-15

打赏
举报

[Quote=引用 9 楼 meboss 的回复:]

引用 5 楼 sysdzw 的回复:

引用 3 楼 meboss 的回复:

不是吧有怎么麻烦吗
这是模块代码
Public Type a
i As Integer
B As String
c As Single
d As Double
e As Long
f As Byte
asd(2) As Double
End Type

这是窗体里面的代码：
Pu……
哥们你说的可是这样？？？
[/Quote]是啊，你先试试楼上说的friend声明的方法呢。

MeBoss 2011-09-15

打赏
举报

[Quote=引用 5 楼 sysdzw 的回复:]

引用 3 楼 meboss 的回复:

不是吧有怎么麻烦吗
这是模块代码
Public Type a
i As Integer
B As String
c As Single
d As Double
e As Long
f As Byte
asd(2) As Double
End Type

这是窗体里面的代码：
Public Sub abc(c As a)
……
[/Quote]
Public qwe As a

Public Sub abc()

MsgBox qwe.c
End Sub

Private Sub Command2_Click()
Dim w As a
w.c = 10
qwe = w

Call abc
End Sub

哥们你说的可是这样？？？

MeBoss 2011-09-15

打赏
举报

呵呵那个问题也是我问的，最终有人说用friend 可以解决，确实可以解决但是问题是在标准模块中无法使用

VBToy 2011-09-15

打赏
举报

这个问题都回答N次了
http://topic.csdn.net/u/20110519/21/6f7b5f30-4f12-43f7-b679-36a7b887befd.html

ttsffgg 2011-09-15

打赏
举报

我記得在activeExe中可以

贝隆 2011-09-14

打赏
举报



'------------------------------------------------------------------------------



'Form Code 

'------------------------------------------------------------------------------ 

'Add two Command buttons to the form (Command1/Command2), as 

'well as a listbox (List1) and a ListView (ListView1). Add three or more 

'ColumnHeaders to the ListView and set it to report mode. Important - 

'name the form frmMain (to match the HookMe code above) and add 

'the following code: 



Option Explicit



Friend Function WindowProc(hwnd As Long, _

                           msg As Long, _

                           wp As Long, _

                           lp As Long) As Long

   

   Static nm As NMHDR

   Static pt As POINTAPI

   Static HTI As HD_HITTESTINFO

    

   Dim hHeader As Long

   Dim thisIndex As Long

   

   If hwnd = ListView1.hwnd Then

  

      Select Case msg

         Case WM_NOTIFY

         

           'Pass along to default window procedure.

            WindowProc = CallWindowProc(GetProp(hwnd, _

                                               "OldWindowProc"), _

                                               hwnd, msg, _

                                               wp, lp)

            

           'Get the notification message

            Call CopyMemory(nm, ByVal lp, Len(nm))

            

           'get the hwnd of the header

            hHeader = SendMessage(ListView1.hwnd, _

                                         LVM_GETHEADER, _

                                         0&, _

                                         ByVal 0&)

            

            If hHeader Then



              'get the current cursor position in the header

               Call GetCursorPos(pt)

               Call ScreenToClient(hHeader, pt)

               

              'get the header's hit-test info

               With HTI

                  .flags = HHT_ONHEADER Or HHT_ONDIVIDER

                  .pt = pt

               End With

   

               Call SendMessage(hHeader, HDM_HITTEST, 0&, HTI)

                     

              'react to the HDN_ code

               Select Case nm.code

            

                  Case HDN_ENDTRACK

                     List1.AddItem _

                           "HDN_ENDTRACK" & _

                           vbTab & vbTab & _

                           pt.X & vbTab & pt.Y

                     

                  Case HDN_BEGINTRACK

                     List1.AddItem _

                           "HDN_BEGINTRACK" & _

                           vbTab & _

                           "(attempting to) resize " & HTI.iItem

                     

                    'if this is the divider after the third

                    'header, prevent resizing by passing 1

                    'as the result of the WindowProc

                     If HTI.iItem = 2 Then WindowProc = 1: Exit Function



                  Case HDN_ITEMCHANGING

                     List1.AddItem _

                           "HDN_ITEMCHANGING" & _

                           vbTab & pt.X & vbTab & pt.Y

                  

                  Case HDN_BEGINDRAG

                     List1.AddItem _

                           "HDN_BEGINDRAG" & _

                           vbTab & _

                           "Begin header " _

                           & HTI.iItem & _

                           " drag"

                  

                  Case HDN_ENDDRAG

                     List1.AddItem _

                           "HDN_ENDDRAG" & _

                           vbTab & vbTab & _

                           "End header " & _

                           HTI.iItem & " drag"

                  

                  Case HDN_DIVIDERDBLCLICK

                     List1.AddItem _

                           "HDN_DIVIDERDBLCLICK" & _

                           vbTab & _

                           " at item: " & _

                           HTI.iItem

                    

                  Case NM_RCLICK

                     List1.AddItem _

                           "NM_RCLICK" & _

                           vbTab & vbTab & _

                           " on item: " & _

                           HTI.iItem

                  

                  Case HDN_ITEMCLICK

                     List1.AddItem _

                           "HDN_ITEMCLICK" & _

                           vbTab & vbTab & _

                           " on item: " & _

                           HTI.iItem

                     

                  Case Else

               End Select

               

            End If 'If hHeader Then

         

         Case Else

      

      End Select  'Select Case msg

   

   End If  'If hwnd = ListView1.hwnd



   WindowProc = CallWindowProc(GetProp(hwnd, _

                               "OldWindowProc"), _

                               hwnd, msg, wp, lp)

            

  'keep the last list entry in view

   List1.ListIndex = List1.ListCount - 1



End Function





Private Sub Command1_Click()



   Call HookWindow(ListView1.hwnd, Me)

   

   Command1.Caption = "Subclassed!"

   Command1.Enabled = False

   Label1.Caption = "Click, drag and double click the header and column dividers"

   

End Sub





Private Sub Command2_Click()



   Unload Me

   

End Sub





Private Sub Form_Load()



  'assure that the common control library is loaded

   Call IsNewComctl32(ICC_LISTVIEW_CLASSES)



End Sub





Private Sub Form_Unload(Cancel As Integer)



   Call UnhookWindow(ListView1.hwnd)



End Sub

贝隆 2011-09-14

打赏
举报

可以，比如：



'Example Name: Notifications from the ListView Header 



'------------------------------------------------------------------------------



' BAS Module 1 Code: HookMe.bas 

'------------------------------------------------------------------------------



Option Explicit

Public Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long,ByVal lpString As String) As Long



Public 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



Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal wNewWord As Long) As Long



Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long



Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Private Const GWL_WNDPROC  As Long = (-4)

Public Function HookFunc(ByVal hwnd As Long, ByVal msg As Long, ByVal wp As Long, ByVal lp As Long) As Long

   Dim foo As Long

   Dim obj As frmMain

   foo = GetProp(hwnd, "ObjectPointer")

   ' Ignore "impossible" bogus case

   If (foo <> 0) Then

      CopyMemory obj, foo, 4

      On Error Resume Next

      HookFunc = obj.WindowProc(hwnd, msg, wp, lp)

      If (Err) Then

         UnhookWindow hwnd

         Debug.Print "Unhook on Error, #"; CStr(Err.Number)

         Debug.Print "  Desc: "; Err.Description

         Debug.Print "  Message, hWnd: &h"; Hex(hwnd), "Msg: &h"; Hex(msg), "Params:"; wp; lp

      End If

      ' Make sure we don't get any foo->Release() calls

      foo = 0

      CopyMemory obj, foo, 4

   End If

End Function

Public Sub HookWindow(hwnd As Long, thing As Object)

   Dim foo As Long

   CopyMemory foo, thing, 4

   Call SetProp(hwnd, "ObjectPointer", foo)

   Call SetProp(hwnd, "OldWindowProc", GetWindowLong(hwnd, GWL_WNDPROC))

   Call SetWindowLong(hwnd, GWL_WNDPROC, AddressOf HookFunc)

End Sub

Public Sub UnhookWindow(hwnd As Long)

   Dim foo As Long

   foo = GetProp(hwnd, "OldWindowProc")

   If (foo <> 0) Then

      Call SetWindowLong(hwnd, GWL_WNDPROC, foo)

   End If

End Sub

Public Function InvokeWindowProc(hwnd As Long, msg As Long, wp As Long, lp As Long) As Long

   InvokeWindowProc = CallWindowProc(GetProp(hwnd, "OldWindowProc"), hwnd, msg, wp, lp)

End Function

'------------------------------------------------------------------------------



' BAS Module 2 Code: ListView Header API

'------------------------------------------------------------------------------

Option Explicit

Public Const ICC_LISTVIEW_CLASSES  As Long = &H1

Public Const LVM_FIRST = &H1000

Public Const LVM_GETHEADER = (LVM_FIRST + 31)

Public Type NMHDR

   hWndFrom As Long

   idfrom   As Long

   code     As Long

End Type

Public Type HD_ITEM

   mask        As Long

   cxy         As Long

   pszText     As String

   hbm         As Long

   cchTextMax  As Long

   fmt         As Long

   lParam      As Long

   iImage      As Long

   iOrder      As Long

End Type

Public Type NMHEADER

   hdr         As NMHDR

   iItem       As Long

   iButton     As Long

   hbm         As Long

   HDI         As HD_ITEM

End Type

Public Type POINTAPI

   X As Long

   Y As Long

End Type

Public Type HD_HITTESTINFO

   pt  As POINTAPI

   flags  As Long

   iItem As Long

End Type

Public Type tagINITCOMMONCONTROLSEX 

   dwSize As Long 

   dwICC As Long

End Type

'HitTest positions

Public Const HHT_NOWHERE = &H1

Public Const HHT_ONHEADER = &H2

Public Const HHT_ONDIVIDER = &H4

Public Const HHT_ONDIVOPEN = &H8

Public Const HHT_ABOVE = &H100

Public Const HHT_BELOW = &H200

Public Const HHT_TORIGHT = &H400

Public Const HHT_TOLEFT = &H800

'header class id's

Public Const HEADER32_CLASS   As String = "SysHeader32"

Public Const HEADER_CLASS     As String = "SysHeader"

'header info

Public Const HDI_WIDTH        As Long = &H1

Public Const HDI_HEIGHT       As Long = HDI_WIDTH

Public Const HDI_TEXT         As Long = &H2

Public Const HDI_FORMAT       As Long = &H4

Public Const HDI_LPARAM       As Long = &H8

Public Const HDI_BITMAP       As Long = &H10

Public Const HDI_IMAGE        As Long = &H20

Public Const HDI_DI_SETITEM   As Long = &H40

Public Const HDI_ORDER        As Long = &H8

'header formats

Public Const HDF_LEFT         As Long = 0

Public Const HDF_RIGHT        As Long = 1

Public Const HDF_CENTER       As Long = 2

Public Const HDF_JUSTIFYMASK  As Long = &H3

Public Const HDF_RTLREADING   As Long = 4

Public Const HDF_IMAGE        As Long = &H800

Public Const HDF_OWNERDRAW    As Long = &H8000&

Public Const HDF_STRING       As Long = &H4000

Public Const HDF_BITMAP       As Long = &H2000

Public Const HDF_BITMAP_ON_RIGHT  As Long = &H1000

'header styles

Public Const HDS_HORZ         As Long = &H0

Public Const HDS_BUTTONS      As Long = &H2

Public Const HDS_HOTTRACK     As Long = &H4

Public Const HDS_HIDDEN       As Long = &H8

Public Const HDS_DRAGDROP     As Long = &H40

Public Const HDS_FULLDRAG     As Long = &H80

'header messages

Public Const HDM_FIRST           As Long = &H1200

Public Const HDM_GETITEMCOUNT    As Long = (HDM_FIRST + 0)

Public Const HDM_INSERTITEM      As Long = (HDM_FIRST + 1)

Public Const HDM_DELETEITEM      As Long = (HDM_FIRST + 2)

Public Const HDM_GETITEM         As Long = (HDM_FIRST + 3)

Public Const HDM_SETITEM         As Long = (HDM_FIRST + 4)

Public Const HDM_LAYOUT          As Long = (HDM_FIRST + 5)

Public Const HDM_HITTEST         As Long = (HDM_FIRST + 6)

Public Const HDM_GETITEMRECT     As Long = (HDM_FIRST + 7)

Public Const HDM_SETIMAGELIST    As Long = (HDM_FIRST + 8)

Public Const HDM_GETIMAGELIST    As Long = (HDM_FIRST + 9)

Public Const HDM_ORDERTOINDEX    As Long = (HDM_FIRST + 15)

'notify messages

Public Const HDN_FIRST As Long = -300&  

Public Const HDN_ITEMCLICK = (HDN_FIRST - 2)

Public Const HDN_DIVIDERDBLCLICK = (HDN_FIRST - 5)

Public Const HDN_BEGINTRACK = (HDN_FIRST - 6)

Public Const HDN_ENDTRACK = (HDN_FIRST - 7)

Public Const HDN_TRACK = (HDN_FIRST - 8)

Public Const HDN_GETDISPINFO = (HDN_FIRST - 9)

Public Const HDN_BEGINDRAG = (HDN_FIRST - 10)

Public Const HDN_ENDDRAG = (HDN_FIRST - 11)

Public Const HDN_ITEMCHANGING As Long = (HDN_FIRST - 0)

Public Const HDN_ITEMDBLCLICK As Long = (HDN_FIRST - 3)

Public Const NM_FIRST As Long = &H0

Public Const NM_RCLICK As Long = (NM_FIRST - 5)

'windows constants

Public Const GWL_STYLE        As Long = (-16)

Public Const WM_USER  As Long = &H400

Public Const WM_SIZE  As Long = &H5

Public Const WM_NOTIFY        As Long = &H4E&

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Public Declare Function GetWindowLong Lib "user32" _Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long

Public Declare Sub InitCommonControls Lib "comctl32" ()

Public Declare Function InitCommonControlsEx Lib "comctl32" (lpInitCtrls As tagINITCOMMONCONTROLSEX) As Boolean

Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long

Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Any, lParam As Any) As Long

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long



Public Function IsNewComctl32(dwFlags As Long) As Boolean

'Returns True if the current working version of Comctl32.dll

'supports the new IE3 styles & msgs. Returns False if old version.

'Also ensures that the Comctl32.dll library is loaded for use.

'This hack is much easier than checking the file version...

'VB resolves API function names only when they're called,

'not when it compiles code!

   Dim icc As tagINITCOMMONCONTROLSEX

 On Error GoTo Err_InitOldVersion

   icc.dwSize = Len(icc)

   icc.dwICC = dwFlags

  'VB will generate error 453 "Specified DLL function not found"

  'here if the new version isn't installed.

   IsNewComctl32 = InitCommonControlsEx(icc)

   Exit Function

Err_InitOldVersion:

   InitCommonControls

End Function