?? messengerorig.frm
字號:
lpRemoteName As Long
lpComment As Long
lpProvider As Long
End Type
Const UF_SCRIPT = &H1
Const UF_ACCOUNTDISABLE = &H2
Const UF_HOMEDIR_REQUIRED = &H8
Const UF_LOCKOUT = &H10
Const UF_PASSWD_NOTREQD = &H20
Const UF_PASSWD_CANT_CHANGE = &H40
Const UF_TEMP_DUPLICATE_ACCOUNT = &H100
Const UF_NORMAL_ACCOUNT = &H200
Const UF_INTERDOMAIN_TRUST_ACCOUNT = &H800
Const UF_WORKSTATION_TRUST_ACCOUNT = &H1000
Const UF_SERVER_TRUST_ACCOUNT = &H2000
Const UF_DONT_EXPIRE_PASSWD = &H10000
Const UF_MNS_LOGON_ACCOUNT = &H20000
Dim Info As NETRESOURCE 'To store the resource
Dim Domn As Boolean 'Flag set when enumerating Domain(s)
Dim DTyp As String 'To store the Domain Name
Dim tUsr As String 'Name of the Current User
Dim lUsr As Long 'Length of the User Name
Dim X As Long 'General storage for Return Value(s)
Private Function Enumerate(Info As NETRESOURCE) As Long
'This function is used Recursively to enumerate Workstations/Domains in a Network
Dim EnumerationHandle&
Dim res&
Dim tbuf() As Byte
Dim BufferSize As Long
DoEvents
'Open the Network
res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK, 0, Info, EnumerationHandle)
If res <> 0 Then
Exit Function
End If
ReDim tbuf(16384)
BufferSize = 16384 'Minimum 16 KB Kaka
Do
DoEvents
'Enumerate the Resources
res = WNetEnumResource(EnumerationHandle, 1, tbuf(0), BufferSize)
' Check for errors
Select Case res
Case 0 ' Success
Load agGetAddressForObject(tbuf(0))
Case Else
If res = ERROR_MORE_DATA Then ReDim tbuf(BufferSize + 1) Else: Exit Do
End Select
Loop While res = 0
' And close the enumeration
res = WNetCloseEnum(EnumerationHandle)
Enumerate = 0
End Function
Public Sub Load(ByVal bufferaddress&)
'nr stores the addresses for all the values
Dim nr As NETRESOURCELONG ' Temporary structure for copying
agCopyData ByVal bufferaddress, nr, Len(nr) ' Copy the necessary data
LoadInfoFromNRLong nr ' Call this function to Load Values from Pointer Addr.
End Sub
Private Sub LoadInfoFromNRLong(nr As NETRESOURCELONG)
'This function is used to Load values into strings from Pointer Addresses
Info.dwScope = nr.dwScope
Info.dwType = nr.dwType
Info.dwDisplayType = nr.dwDisplayType
Info.dwUsage = nr.dwUsage
If nr.lpRemoteName <> 0 Then
Info.lpRemoteName = agGetStringFromPointer(nr.lpRemoteName) & Chr$(0)
Else
Info.lpRemoteName = vbNullString
End If
'Determine the type of resource
Select Case Info.dwDisplayType
Case RESOURCEDISPLAYTYPE_DOMAIN
DTyp = " Domain "
If Domn = True Then 'If search is for Domain(s) list and exit
cboWorkstation.AddItem Chr(32) & Info.lpRemoteName
Else
X& = Enumerate(Info) 'Look for further computers
End If
Case RESOURCEDISPLAYTYPE_GENERIC
DTyp = " Generic "
Case RESOURCEDISPLAYTYPE_GROUP
DTyp = " Group "
Case RESOURCEDISPLAYTYPE_SERVER
DTyp = " Server "
If Domn = False Then 'If search is for Workstations(s) list and exit
cboWorkstation.AddItem Trim(Mid(Info.lpRemoteName, 3, Len(Info.lpRemoteName)))
End If
Case RESOURCEDISPLAYTYPE_SHARE
DTyp = " Share "
Case RESOURCEDISPLAYTYPE_FILE
DTyp = " File "
End Select
End Sub
Private Sub cboSelected_GotFocus()
'Tell user what this will do
lblStatus = "按 DEL 鍵刪除用戶."
End Sub
Private Sub cboSelected_KeyDown(KeyCode As Integer, Shift As Integer)
'Trapping DEL key so that the user may be removed from the selected List
If cboSelected.ListCount > 0 And cboSelected.ListIndex > -1 And KeyCode = 46 Then
cboSelected.RemoveItem cboSelected.ListIndex
If cboSelected.ListCount > -1 Then
cboSelected.ListIndex = cboSelected.ListCount - 1
End If
End If
End Sub
Private Sub cboWorkstation_Click()
'Selects the user to the Select ComboBox when Group Check is enabled
If cboWorkstation.ListCount > -1 And Len(Trim(cboWorkstation)) > 0 Then
If Mid(cboWorkstation, 1, 1) = "*" Then
chkGroup.Value = 1
Call SessionEnum(2)
ElseIf chkGroup.Value = 1 Then
cboSelected.AddItem cboWorkstation
cboSelected.ListIndex = cboSelected.ListCount - 1
End If
End If
End Sub
Private Sub cboWorkstation_GotFocus()
'Prompt the user to select a Name
If Len(lblStatus) <> 0 Then lblStatus = "可以選擇或者直接輸入發送到達的位置."
End Sub
Private Sub cboWorkstation_KeyPress(KeyAscii As Integer)
'Add the name to the Select Combo on ENTER press
If KeyAscii = 13 Then
If chkGroup.Value = 1 And Len(Trim(cboWorkstation)) Then
cboSelected.AddItem cboWorkstation
cboSelected.ListIndex = cboSelected.ListCount - 1
End If
Else
If KeyAscii = 32 Then KeyAscii = 0 Else KeyAscii = Asc(UCase(Chr(KeyAscii)))
End If
End Sub
Private Sub chkGroup_Click()
'This is used to Display the Select Combo
cboSelected.Clear
cboSelected.Visible = chkGroup
End Sub
Private Sub chkGroup_GotFocus()
'Tell user what this will do
lblStatus = "選擇一個用戶."
End Sub
Private Sub cmdBeep_Click()
'This code sets the Beeper On/Off
Dim xRet&, ySet&, bSet& 'Variables for Return Status, Speaker Status, Set Variable
ySet = Get_Beep
If ySet = 0 Then bSet = 1 Else bSet = 0 'Set bSet to the Opposite of Set Status
xRet = SystemParametersInfo(SPI_SETBEEP, bSet, ySet, 0&)
If xRet <> 0 Then
xRet = Get_Beep
Else
lblStatus = "不發出聲音."
End If
End Sub
Function Get_Beep() As Long
'This code sets the Beeper On/Off
Dim xRet&, ySet& 'Variables for Return Status, Speaker Status
xRet = SystemParametersInfo(SPI_GETBEEP, 0&, ySet, 0&)
If xRet <> 0 Then
If ySet = 0 Then
lblStatus = "關閉聲音."
cmdBeep.BackColor = &H40C0& 'Set to Red to meaning Off
Else
lblStatus = "打開聲音."
cmdBeep.BackColor = &HC0C000 'Set to Green to meaning On
End If
Else
cmdBeep.BackColor = &HC0C0C0 'Set Default color to the Beep Button
lblStatus = "不檢測聲音狀態."
End If
Get_Beep = ySet
End Function
Private Sub cmdBeep_GotFocus()
'Tell user this will set beeper On/Off
lblStatus = "設置聲音是否打開."
End Sub
Private Sub cmdExit_Click()
'Close Messenger, Tata
Unload Me
End Sub
Private Sub cmdExit_GotFocus()
'Tell user this will khatam the Messenger
lblStatus = "結束程序."
End Sub
Private Sub cmdSend_Click()
'This function sends Messages to Names either in Select Combo/ Default Combo
Dim iSel As Integer
Dim tMsg As String
tMsg = txtMsg 'Store actual Message in a string
If chkGroup.Value = 1 Then
If cboSelected.ListCount < 1 Then
Beep
lblStatus = "無選擇."
Else
Me.WindowState = vbMinimized
Me.Caption = "正在發送,請等待 ..."
For iSel = 0 To cboSelected.ListCount - 1
If Len(Trim(cboSelected.List(iSel))) = 0 Or (Left(Trim(cboSelected.List(iSel)), 1) = "*") Then
Beep
lblStatus = "無法發送: " & cboSelected.List(iSel)
Else
Call SendMessage(cboSelected.List(iSel), tMsg)
End If
Next iSel
Me.Caption = "發送消息"
Me.WindowState = vbNormal
End If
Else
If Len(Trim(cboWorkstation)) = 0 Or (Left(Trim(cboWorkstation), 1) = "*") Then
Beep
lblStatus = "選擇或輸入用戶名稱."
Else
Call SendMessage(cboWorkstation, tMsg)
End If
End If
End Sub
Private Sub cmdSend_GotFocus()
'Display whether the Message is to Group or Name
If chkGroup.Value = 1 Then
lblStatus = "發送消息到工作組。"
Else
lblStatus = "發送給: " & cboWorkstation
End If
End Sub
Private Sub domain_Click()
'Calls Enumerate function to select Domain names from the Network
Me.MousePointer = 11
lblStatus = "正在查找域 ..."
Me.Caption = "正在查找域 ..."
cboWorkstation.Clear
Reset_Info
Domn = True
DoEvents: X& = Enumerate(Info) 'To enumerate root, necessary to enumerate the Network
DoEvents: X& = Enumerate(Info) 'To enumerate further
Domn = False
'Beep
If cboWorkstation.ListCount > 0 Then lblStatus = "域被找到."
Me.MousePointer = 1
If cboWorkstation.ListCount > 0 Then cboWorkstation.ListIndex = 0
'Beep
Me.Caption = "發送消息"
txtMsg = ""
End Sub
Private Sub exit_Click()
'This will Khatam the Messenger
End
End Sub
Private Sub Form_Load()
'Prompts the user to enter a Message, Finds Beeper status before
Dim nRet As Long
nRet = SetWindowRgn(Me.hWnd, CreateFormRegion(1, 1, 0, 0), True)
lblStatus = "輸入要發送的消息."
Call Get_Beep 'Finds Beeper Status
Call Get_User 'Gets the User name and attaches it to the Message
End Sub
Private Function CreateFormRegion(ScaleX As Single, ScaleY As Single, OffsetX As Integer, OffsetY As Integer) As Long
Dim Corraction As Integer
Dim HolderRegion As Long, ObjectRegion As Long, nRet As Long, Counter As Integer
Dim PolyPoints() As POINTAPI
ResultRegion = CreateRectRgn(0, 0, 0, 0)
HolderRegion = CreateRectRgn(0, 0, 0, 0)
ObjectRegion = CreateRoundRectRgn( _
shpBorder.Left / Screen.TwipsPerPixelX + OffsetX, _
shpBorder.Top / Screen.TwipsPerPixelY + OffsetY, _
(shpBorder.Left + shpBorder.Width) / Screen.TwipsPerPixelX + OffsetX, _
(shpBorder.Top + shpBorder.Height) / Screen.TwipsPerPixelY + OffsetY, _
RectXRound, RectYRound)
nRet = CombineRgn(HolderRegion, ResultRegion, ResultRegion, RGN_COPY)
nRet = CombineRgn(ResultRegion, HolderRegion, ObjectRegion, 2)
DeleteObject ObjectRegion
DeleteObject ObjectRegion
DeleteObject HolderRegion
CreateFormRegion = ResultRegion
End Function
Private Sub Form_Unload(Cancel As Integer)
DeleteObject ResultRegion
End Sub
Private Sub group_Click()
'Displays Group names, at present the service is not available to this list
lblStatus = "正在查找工作組 ..."
Me.MousePointer = 11
Me.Caption = "正在查找工作組 ..."
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -