MSN 코드 모음

오후 3:35 2002-09-26
MSN 코드 모음 (from msnfantastic.com)
bro@shinbiro.com 조경민
----------------------------------------------------------
Status Changing

put in declarations

Dim WithEvents MsnObj As MsgrObject

this goes in form load.

Private Sub Form_Load()
Set MsnObj = New MsgrObject
End Sub

Now for the status'


Private Sub Command1_Click()
MsnObj.LocalState = MSTATE_ONLINE
End Sub

Private Sub Command2_Click()
MsnObj.LocalState = MSTATE_BE_RIGHT_BACK
End Sub

Private Sub Command3_Click()
MsnObj.LocalState = MSTATE_BUSY
End Sub

Private Sub Command4_Click()
MsnObj.LocalState = MSTATE_AWAY
End Sub

Private Sub Command5_Click()
MsnObj.LocalState = MSTATE_ON_THE_PHONE
End Sub

Private Sub Command6_Click()
MsnObj.LocalState = MSTATE_OUT_TO_LUNCH
End Sub

Private Sub Command7_Click()
MsnObj.LocalState = MSTATE_INVISIBLE
End Sub

Private Sub Command8_Click()
MsnObj.LocalState = MSTATE_INVISIBLE
MsnObj.LocalState = MSTATE_ONLINE
MsnObj.LocalState = MSTATE_INVISIBLE
MsnObj.LocalState = MSTATE_ONLINE
MsnObj.LocalState = MSTATE_INVISIBLE
MsnObj.LocalState = MSTATE_ONLINE
MsnObj.LocalState = MSTATE_INVISIBLE
MsnObj.LocalState = MSTATE_ONLINE
End Sub

the final code there being for online/offline scroll

Make sure u set ya references.

If u still dont understand it email me and i will send u an already coded status changin form


----------------------------------------

Changing the IM Warning

To change the IM warning ''never give out your credit card number etc...
firstly you need to add the following module to your form

Option Explicit

Private m_lngRetVal As Long
Private Const REG_NONE As Long = 0 ' No value type
Private Const REG_SZ As Long = 1 ' nul terminated string
Private Const REG_EXPAND_SZ As Long = 2 ' nul terminated string w/enviornment var
Private Const REG_BINARY As Long = 3 ' Free form binary
Private Const REG_DWORD As Long = 4 ' 32-bit number
Private Const REG_DWORD_LITTLE_ENDIAN As Long = 4 ' 32-bit number (same as REG_DWORD)
Private Const REG_DWORD_BIG_ENDIAN As Long = 5 ' 32-bit number
Private Const REG_LINK As Long = 6 ' Symbolic Link (unicode)
Private Const REG_MULTI_SZ As Long = 7 ' Multiple Unicode strings
Private Const REG_RESOURCE_LIST As Long = 8 ' Resource list in the resource map
Private Const REG_FULL_RESOURCE_DESCRIPTOR As Long = 9 ' Resource list in the hardware description
Private Const REG_RESOURCE_REQUIREMENTS_LIST As Long = 10
Private Const KEY_QUERY_VALUE As Long = &H1
Private Const KEY_SET_VALUE As Long = &H2
Private Const KEY_CREATE_SUB_KEY As Long = &H4
Private Const KEY_ENUMERATE_SUB_KEYS As Long = &H8
Private Const KEY_NOTIFY As Long = &H10
Private Const KEY_CREATE_LINK As Long = &H20
Private Const KEY_ALL_ACCESS As Long = &H3F
Public Const HKEY_CLASSES_ROOT As Long = &H80000000
Public Const HKEY_CURRENT_USER As Long = &H80000001
Public Const HKEY_LOCAL_MACHINE As Long = &H80000002
Public Const HKEY_USERS As Long = &H80000003
Public Const HKEY_PERFORMANCE_DATA As Long = &H80000004
Public Const HKEY_CURRENT_CONFIG As Long = &H80000005
Public Const HKEY_DYN_DATA As Long = &H80000006
Private Const ERROR_SUCCESS As Long = 0
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_NO_MORE_ITEMS As Long = 259
Private Const REG_OPTION_NON_VOLATILE As Long = 0
Private Const REG_OPTION_VOLATILE As Long = &H1
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal lngRootKey As Long) As Long

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" _
(ByVal lngRootKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" _
(ByVal lngRootKey As Long, ByVal lpSubKey As String) As Long

Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" _
(ByVal lngRootKey As Long, ByVal lpValueName As String) As Long

Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal lngRootKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal lngRootKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" _
(ByVal lngRootKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, _
ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Public Function regDelSubKey(ByVal lngRootKey As Long, _
ByVal strRegKeyPath As String, _
ByVal strRegSubKey As String)

' regDelete_Sub_Key HKEY_CURRENT_USER, "Software\AAA-Registry Test\Products", "StringTestData"
Dim lngKeyHandle As Long
If regIsKey(lngRootKey, strRegKeyPath) Then
m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
m_lngRetVal = RegDeleteValue(lngKeyHandle, strRegSubKey)
m_lngRetVal = RegCloseKey(lngKeyHandle)
End If
End Function

Public Function regIsKey(ByVal lngRootKey As Long, _
ByVal strRegKeyPath As String) As Boolean

' strKeyQuery = regIsKey(HKEY_CURRENT_USER, "Software\AAA-Registry Test\Products")
Dim lngKeyHandle As Long
lngKeyHandle = 0
m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
If lngKeyHandle = 0 Then
regIsKey = False
Else
regIsKey = True
End If
m_lngRetVal = RegCloseKey(lngKeyHandle)
End Function

Public Function regReadKey(ByVal lngRootKey As Long, _
ByVal strRegKeyPath As String, _
ByVal strRegSubKey As String) As Variant
' strKeyQuery = regReadKey(HKEY_CURRENT_USER, "Software\AAA-Registry Test\Products", "StringTestData")
Dim intPosition As Integer
Dim lngKeyHandle As Long
Dim lngDataType As Long
Dim lngBufferSize As Long
Dim lngBuffer As Long
Dim strBuffer As String
Dim strTemp As String
lngKeyHandle = 0
lngBufferSize = 0
m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
If lngKeyHandle = 0 Then
regReadKey = ""
m_lngRetVal = RegCloseKey(lngKeyHandle) ' always close the handle
Exit Function
End If
m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, _
lngDataType, ByVal 0&, lngBufferSize)
If lngKeyHandle = 0 Then
regReadKey = ""
m_lngRetVal = RegCloseKey(lngKeyHandle) ' always close the handle
Exit Function
End If
Select Case lngDataType
Case REG_SZ: ' String data (most common)
strBuffer = Space(lngBufferSize)

m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, 0&, _
ByVal strBuffer, lngBufferSize)

If m_lngRetVal <> ERROR_SUCCESS Then
regReadKey = ""
Else
intPosition = InStr(1, strBuffer, Chr(0)) ' look for the first null char
If intPosition > 0 Then
strTemp = Mid$(strBuffer, 1, intPosition - 1)
regReadKey = strTemp
Else
strTemp = strBuffer
regReadKey = strTemp
End If
End If

Case REG_DWORD: ' Numeric data (Integer)
m_lngRetVal = RegQueryValueEx(lngKeyHandle, strRegSubKey, 0&, lngDataType, _
lngBuffer, 4&) ' 4& = 4-byte word (long integer)
If m_lngRetVal <> ERROR_SUCCESS Then
regReadKey = ""
Else
regReadKey = lngBuffer
End If

Case Else: ' unknown
regReadKey = ""
End Select
m_lngRetVal = RegCloseKey(lngKeyHandle)
End Function

Public Sub regWriteSubKey(ByVal lngRootKey As Long, ByVal strRegKeyPath As String, _
ByVal strRegSubKey As String, varRegData As Variant)
' regWriteSubKey HKEY_CURRENT_USER, _
' "Software\AAA-Registry Test\Products", _
' "StringTestData", "22 Jun 1999"
Dim lngKeyHandle As Long
Dim lngDataType As Long
Dim lngKeyValue As Long
Dim strKeyValue As String
If IsNumeric(varRegData) Then
lngDataType = REG_DWORD
Else
lngDataType = REG_BINARY
End If
m_lngRetVal = RegCreateKey(lngRootKey, strRegKeyPath, lngKeyHandle)
Select Case lngDataType
Case REG_BINARY: ' String data
strKeyValue = Trim(varRegData) & Chr(0) ' null terminated
m_lngRetVal = RegSetValueEx(lngKeyHandle, strRegSubKey, 0&, lngDataType, _
ByVal strKeyValue, Len(strKeyValue))

Case REG_DWORD: ' numeric data
lngKeyValue = CLng(varRegData)
m_lngRetVal = RegSetValueEx(lngKeyHandle, strRegSubKey, 0&, lngDataType, _
lngKeyValue, 4&) ' 4& = 4-byte word (long integer)

End Select
m_lngRetVal = RegCloseKey(lngKeyHandle)
End Sub

Public Function regWriteKey(ByVal lngRootKey As Long, ByVal strRegKeyPath As String)
' regWriteKey HKEY_CURRENT_USER, "Software\AAA-Registry Test"
' regWriteKey HKEY_CURRENT_USER, "Software\AAA-Registry Test\Products"
Dim lngKeyHandle As Long
m_lngRetVal = RegCreateKey(lngRootKey, strRegKeyPath, lngKeyHandle)
m_lngRetVal = RegCloseKey(lngKeyHandle)
End Function

Public Function regDelKey(ByVal lngRootKey As Long, _
ByVal strRegKeyPath As String, _
ByVal strRegKeyName As String) As Boolean
' regDelKey HKEY_CURRENT_USER, "Software", "AAA-Registry Test"
Dim lngKeyHandle As Long
regDelKey = False
If regIsKey(lngRootKey, strRegKeyPath) Then
m_lngRetVal = RegOpenKey(lngRootKey, strRegKeyPath, lngKeyHandle)
m_lngRetVal = RegDeleteKey(lngKeyHandle, strRegKeyName)
If m_lngRetVal = 0 Then regDelKey = True
m_lngRetVal = RegCloseKey(lngKeyHandle)
End If
End Function

Then add this in declarations

Dim WithEvents MsnObj As MsgrObject

Then put this in form load


Private Sub Form_Load()
Set MsnObj = New MsgrObject
End Sub


Then add 1 text box and 1 command button

Private Sub Command1_Click()
CreateKey "HKLM\Software\Microsoft\MessengerService\Policies\IMWarning", Text1.Text


Then finally add these pieces of simple code to your form

Public Sub CreateKey(Folder As String, Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value

End Sub

Public Sub CreateIntegerKey(Folder As String, Value As Integer)

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
b.RegWrite Folder, Value, "REG_DWORD"


End Sub

Public Function ReadKey(Value As String) As String

Dim b As Object
On Error Resume Next
Set b = CreateObject("wscript.shell")
r = b.RegRead(Value)
ReadKey = r
End Function


Public Sub DeleteKey(Value As String)

Dim b As Object
On Error Resume Next
Set b = CreateObject("Wscript.Shell")
b.RegDelete Value
End Sub
-----------------------------------------------------

Change Nickname

Put this in declarations

Dim WithEvents MsnObj As MsgrObject

an in form load put

Private Sub Form_Load()
Set MsnObj = New MsgrObject
End Sub

You now need 1 command button and 1 text box respectivly

Private Sub Command1_Click()
MsnObj.Services(1).FriendlyName = (Text1.Text) 'changes current nick to text1
End Sub

And finally also add this to the source code area of your form

Private Sub ChangeNick(Nickname$)
On Error GoTo NAMERR
Nickname$ = Left(Nickname$, 129)
mm.Services(0).FriendlyName = Nickname$

Exit Sub
NAMERR:
mm.Services(1).FriendlyName = Nickname$
End Sub
-------------------------------------------

Multi name sign in scroll

put in the declarations

Dim WithEvents MsnObj As MsgrObject
Public WithEvents mm As MsgrObject

then in the form load put:

Private Sub Form_Load()
Set MsnObj = New MsgrObject
End Sub

Then add 1 command button and 4 text box'

Private Sub Command2_Click()
Set mm = New MsgrObject
mm.LocalState = MSTATE_INVISIBLE
ChangeNick Text1.Text
mm.LocalState = MSTATE_ONLINE
mm.LocalState = MSTATE_INVISIBLE
ChangeNick Text2.Text
mm.LocalState = MSTATE_ONLINE
mm.LocalState = MSTATE_INVISIBLE
ChangeNick Text3.Text
mm.LocalState = MSTATE_ONLINE
mm.LocalState = MSTATE_INVISIBLE
ChangeNick Text4.Text
mm.LocalState = MSTATE_ONLINE
End Sub  
  
-----------------------------------
Simple buddylist

Set general declarations:

Public X As Integer
Public MsnObjUsers As IMsgrUsers
Public AllUsers As String
Public WithEvents MsnObj As MsgrObject

Put in the form load

Private Sub Form_Load()
Set Msg = New MsgrObject
GetPeople List1
End Sub

Code

Public Sub GetPeople(LV As ListBox)
Set MsnObjUsers = MsnObj.List(MLIST_CONTACT)
For X = 0 To MsnObjUsers.Count - 1
LV.AddItem MsnObjUsers.Item(X).FriendlyName
Set MsnObjUsers = MsnObj.List(MLIST_CONTACT)
Next X
End Sub
-------------------------------------------------------
Mass Messaging

This code will enable you to send a message to everyone on your list or allow list,

Set the declarations:

Dim WithEvents MsnObj As MsgrObject

And put the following in the form load:

Private Sub Form_Load()
Set MsnObj = New MsgrObject
End Sub

Then you need to add 1 command button and 1 text box

And finally add the following to your source code area:

Private Sub Command1_Click()
On Error Resume Next
MassMsg = Text1.Text
For Each User In MsnObj.List(MLIST_ALLOW)
User.SendText "MIME-Version: 1.0" & vbCrLf & "Content-Type: text/plain; charset=UTF-8" & vbCrLf & "X-MMS-IM-Format: EF=; CO=0000FF; CS=0; PF=12" & vbCrLf & vbCrLf, MassMsg, MMSGTYPE_NORESULT
Next
End Sub

---------------------------------
' =====================
' REQUIRED DECLARATIONS
' =====================
Dim WithEvents msnApp As Messenger.MsgrObject 'The important one
Dim msnUsers As Messenger.IMsgrUsers 'A reference to a list of users
Dim msnUser As Messenger.IMsgrUser 'A single user

' ======================================================
' INSTANTIATING MAIN OBJECT AND LOADING THE CONTACT LIST
' ======================================================
Dim lngContactNo As Long 'Iterates through contacts
    
'Instantiate messenger object
Set msnApp = New Messenger.MsgrObject
Set msnUsers = msnApp.List(0)
        
'Update contact list drop-down
lngContactNo = 0
For Each msnUser In msnUsers
    cmbContact.AddItem msnUser.FriendlyName
    cmbContact.ItemData(cmbContact.NewIndex) = lngContactNo
    lngContactNo = lngContactNo + 1
Next    

' ==========
' AUTO LOGON
' ==========
Private Sub msnApp_OnLogoff()