欢迎.frm

来自「VOD卡拉OK点歌系统源码」· FRM 代码 · 共 292 行

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form 工程 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   7230
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   9615
   LinkTopic       =   "Form1"
   ScaleHeight     =   7230
   ScaleWidth      =   9615
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   7215
      Left            =   0
      Picture         =   "欢迎.frx":0000
      ScaleHeight     =   7185
      ScaleWidth      =   9585
      TabIndex        =   0
      Top             =   0
      Width           =   9615
      Begin MSWinsockLib.Winsock Winsock1 
         Left            =   4800
         Top             =   4920
         _ExtentX        =   741
         _ExtentY        =   741
         _Version        =   393216
      End
   End
End
Attribute VB_Name = "工程"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const WM_CLOSE = &H10
Const WM_QUIT = &H12

Dim Handle As Long
Dim n As Integer

Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private r As Long
Private entry As String
Private iniPath As String
Public keysn As String

  Dim strCharB, strCharA
  Dim strSectionTemp As String
  Dim strNameTemp As String
  Dim strreturn As String

Private Type HOSTENT
   hName As Long
   hAliases As Long
   hAddrType As Integer
   hLength As Integer
   hAddrList As Long
End Type

Private Type WSADATA
   wversion As Integer
   wHighVersion As Integer
   szDescription(0 To WSADescription_Len) As Byte
   szSystemStatus(0 To WSASYS_Status_Len) As Byte
   iMaxSockets As Integer
   iMaxUdpDg As Integer
   lpszVendorInfo As Long
End Type

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetPrivateProfileString Lib "Kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "Kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "Kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)


Function hibyte(ByVal wParam As Integer)
   
   hibyte = wParam \ &H100 And &HFF&
   
End Function

Function lobyte(ByVal wParam As Integer)
   
   lobyte = wParam And &HFF&
   
End Function

Public Sub SocketsInitialize()
   
   Dim WSAD As WSADATA
   Dim iReturn As Integer
   Dim sLowByte As String, sHighByte As String, sMsg As String
   
   iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
   
   If iReturn <> 0 Then
      MsgBox "Winsock.dll is not responding."
      End
   End If
   
   If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
      sHighByte = Trim$(str$(hibyte(WSAD.wversion)))
      sLowByte = Trim$(str$(lobyte(WSAD.wversion)))
      sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
      sMsg = sMsg & " is not supported by winsock.dll "
      MsgBox sMsg
      End
   End If
   
   If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
      sMsg = "This application requires a minimum of "
      sMsg = sMsg & Trim$(str$(MIN_SOCKETS_REQD)) & " supported sockets."
      MsgBox sMsg
      End
   End If
End Sub

Sub SocketsCleanup()
   Dim lReturn As Long
   
   lReturn = WSACleanup()
   
   If lReturn <> 0 Then
      MsgBox "Socket error " & Trim$(str$(lReturn)) & " occurred in Cleanup "
      End
   End If
End Sub
Function GetProfile(strFileName As String, strSection As String, strName As String) As String
   strSectionTemp = ""
   strNameTemp = ""
   strreturn = ""
   On Error GoTo ErrSrchSection
   Open strFileName For Input As #1
   ' 下面这段程序是用来查找节点的
     Do While Not EOF(1)
        strCharA = Input(1, #1)
        If strCharA = "[" Then
           Do While Not EOF(1)
             strCharB = Input(1, #1)
             If strCharB = "]" Then Exit Do
             strSectionTemp = strSectionTemp & strCharB
           Loop
        End If
        If strSectionTemp = strSection Then
          strCharA = Input(2, #1)
          Exit Do
        Else
          strSectionTemp = ""
        End If
     Loop
 On Error GoTo ErrReadFile
  
aa:
    '下面这段程序是用来查找所要查找的字段的
    strNameTemp = ""
    Do While Not EOF(1)
      strCharA = Input(1, #1)
      If strCharA <> "=" Then
        strNameTemp = strNameTemp & strCharA  '得到名称
      Else
        Exit Do
      End If
    Loop
        If strNameTemp = strName Then
       Line Input #1, strreturn  '如果找到与它匹配的字段名，就返回得到的值
    Else
       Line Input #1, strreturn  '如果未找到与它匹配的字段名，就继续找
       GoTo aa
    End If
    Close #1
    GetProfile = strreturn
    Exit Function
ErrReadFile:
    Dim inrRet As Integer
    inrRet = MsgBox("在文件中没有找到所要查找的字段", vbAbortRetryIgnore, "错误信息")
    Select Case inrRet
       Case vbAbort
          GetProfile = ""
          Close #1
          Exit Function
       Case vbRetry
          Resume
       Case vbIgnore
          Resume Next
     End Select
ErrSrchSection:
     MsgBox "节点未找到", vbOKOnly
     GetProfile = ""
     Close #1
End Function

Private Sub Command1_Click()

End Sub

Private Sub Form_Load()
 Winsock1.Close
 
'setscr.SetDisplayMode& 640, 480, 16

          SocketsInitialize
          
          iniPath = App.path & "\vod.ini"
          pf.serverip = GetProfile(iniPath, "Client", "ServerIP")
          pf.serverport = GetProfile(iniPath, "Client", "serverport")
          pf.pcname = GetProfile(iniPath, "Client", "clientname")
          'pf.clinetport = "4888"
          Winsock1.RemoteHost = pf.serverip
          Winsock1.RemotePort = pf.serverport
         'MsgBox (pf.serverip & "  " & pf.serverport)
         'Winsock1.LocalPort = pf.clinetport
          Winsock1.Connect
          'keysn = GetProfile(iniPath, "key", "keysn")
End Sub

Private Sub Label12_Click(Index As Integer)

End Sub
Private Sub Picture1_Click()

   Dim text1
   Dim hostent_addr As Long
   Dim host As HOSTENT
   Dim hostip_addr As Long
   Dim temp_ip_address() As Byte
   Dim i As Integer
   Dim ip_address As String
   
   'MsgBox (Winsock1.LocalIP)
   
   hostent_addr = gethostbyname(text1)
   If hostent_addr = 0 Then
      MsgBox "Can't resolve name."
      Exit Sub
   End If
   
   RtlMoveMemory host, hostent_addr, LenB(host)
   RtlMoveMemory hostip_addr, host.hAddrList, 4
   
   ReDim temp_ip_address(1 To host.hLength)
   RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
   
   For i = 1 To 3
      ip_address = ip_address & temp_ip_address(i) & "."
   Next
   ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
   
   If ip_address <> "192.168.0" Then
   MsgBox ("IP不是192.168.0.*或网络出现软件故障")
   End If
   
   主界面.Show
   Unload 工程
   
   On Error GoTo e1
      Winsock1.SendData "please open"
e1:
End Sub

Private Sub Winsock1_Connect()
'MsgBox ("connect ok")
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim str As String
Winsock1.GetData str
If str = "open" Then
 主界面.Show
 Unload 工程
ElseIf str = "close pc" Then
End If
End Sub