Форум программистов, компьютерный форум, киберфорум
Наши страницы
Visual Basic .NET
Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 9, средняя оценка - 5.00
Памирыч
Почетный модератор
20839 / 8721 / 1079
Регистрация: 11.04.2010
Сообщений: 11,012
#1

Visual Basic .NET FAQ. Готовые решения, полезные коды - Visual Basic .NET

18.08.2011, 22:44. Просмотров 264536. Ответов 194
Метки faq (Все метки)

Предлагаю в этой теме размещать ответы на часто задаваемые вопросы и просто делиться полезными кодами.
Обращаю внимание на некоторые моменты, которые являются дополнением к основным правилам
  1. Запрещается копировать материалы с других сайтов или форумов
  2. Решения должны быть написаны с использованием языка Visual Basic .NET
  3. Запрещено создавать посты с уточнениями и замечаниями. Такие вопросы задавайте на форуме
  4. Код, в котором присутствуют комментарии, читается и понимается намного легче и быстрее
  5. Длинные коды и объемные вопросы одного содержания заключайте в теги [SPОILER]Большой код[/SPОILER]
  6. При создании поста убедитесь, что этот вопрос не был освещен ранее
  7. Код должен быть написан грамотно, большие и неэффективные коды будут удаляться
  8. Список вопросов по конкретной теме нельзя "разрывать" на 2 и более поста

Просьба к постившим: не спешите постить решения "сгоряча", тщательно обдумайте список вопросов, их тематику и порядок
Если вы найдете информацию, которой можно было бы дополнить ваши предыдущие сообщения, что-то изменить или перегруппировать, пишите в л/с.

http://www.cyberforum.ru/vb-net/thread533391.html



 Комментарий модератора 
Данные правила обязательны к исполнению в рамках темы


Примечание: некоторые коды приведены без учета строгой типизации (Параметр Strict), поэтому для их использования необходимо выполнить приведение типов
48
Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
18.08.2011, 22:44
Я подобрал для вас темы с готовыми решениями и ответами на вопрос Visual Basic .NET FAQ. Готовые решения, полезные коды (Visual Basic .NET):

Visual Basic .Net и Visual Basic 6.0 - В чём разница
В общем возник вопрос: Visual Bisic.Net и Visual Basic - это два разных языка, или же .NET версия это лишь его улучшение. Я так понимаю что...

Visual Basic.Net и Visual Studio 2013 - в чем разница?
Visual Basic.Net и Visual Studio 2013 - в чем разница? Или это одно и тоже, просто называются по другому. Планирую перейти с VB6.0...

Visual Basic .NET vs Visual FoxPro 9.0 в рамках задач реляционной модели данных
Очень хочется обсудить следующую тему. Поставлена задача - написать некоторую программу обработки данных. Все данные, обрабатываемые...

Исходники на Visual Basic .NET
Кто-то читает книжки. Кто-то ищет информацию в Google... А кто-то набирается знаний, разбирая чужие исходники. В этой теме предлагается...

Литература и ресурсы по Visual Basic .NET
Литература по Visual Basic.NET 1. Виктор Зиборов "Visual Basic 2010 на примерах" Издательство: БХВ-Петербург Год издания: 2010...

Аналог TStringList в Visual Basic.NET
Здравствуйте все! Помогите разобраться мне надо строки в текстовом файле сохранять в виде списка строк ну и соответственно...

Visual Basic.Net и Visual Studio 2013 - в чем разница?
Visual Basic.Net и Visual Studio 2013 - в чем разница? Или это одно и тоже,...

Visual Basic .NET vs Visual FoxPro 9.0 в рамках задач реляционной модели данных
Очень хочется обсудить следующую тему. Поставлена задача - написать...

Исходники на Visual Basic .NET
Кто-то читает книжки. Кто-то ищет информацию в Google... А кто-то набирается...

Литература и ресурсы по Visual Basic .NET
Литература по Visual Basic.NET 1. Виктор Зиборов "Visual Basic 2010 на...

Аналог TStringList в Visual Basic.NET
Здравствуйте все! Помогите разобраться мне надо строки в текстовом файле...

194
abbat81
29 / 29 / 2
Регистрация: 20.07.2011
Сообщений: 390
30.12.2011, 21:00 #21
Как влючить компютер по сети или "Wake on LAN" (WOL)

На компютере, который нужно включать по сети, в BIOS должна быть включена функция Wake on LAN = Enabled

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
 
Public Class clsWOL
    Const lenHeader As Integer = 6
    Const lenMAC As Integer = 6
    Const repMAC As Integer = 16
 
    Dim mEndPoint As IPEndPoint
    Dim mMACAddress As Byte()
    Dim mBytesSent As Integer = 0
    Dim mPacketSent As String
 
    ''' <summary>
    ''' The IPEndPoint object that will act as a trasport for the packet.
    ''' It is automatically created by New statement, but you can modify it or read it.
    ''' </summary>
    ''' <value>An IPEndPoint object</value>
    ''' <returns>An IPEndPoint object</returns>
    ''' <remarks>Normally there is no need to change this manually.</remarks>
    Public Property endPoint() As IPEndPoint
        Get
            Return mEndPoint
        End Get
        Set(ByVal value As IPEndPoint)
            mEndPoint = value
        End Set
    End Property
    ''' <summary>
    ''' The target machine Network Interface Card MAC address.
    ''' It must be dash-separated, i.e. in the 11-22-33-44-55-66 form
    ''' </summary>
    ''' <value>A string with dash-separated values</value>
    ''' <returns>A string with dash-separated values</returns>
    ''' <remarks>The standard (IEEE 802) separator for cotet are dash (-) and semicolon (:). I resolved to use dashes only in order to avoid any possible confusion and misunderstanding with upcoming IPv6 addressing space.</remarks>
    Public Property macAddress() As String
        Get
            Dim textMAC As New StringBuilder
 
            For Each currByte As Byte In mMACAddress
                textMAC.Append("-")
                textMAC.Append(currByte.ToString("X2"))
            Next
 
            Return textMAC.ToString.Substring(1)
        End Get
        Set(ByVal value As String)
            Dim values As Byte()
 
            For Each currByte As String In value.Split("-")
                If values Is Nothing Then
                    ReDim values(0)
                Else
                    ReDim Preserve values(values.GetUpperBound(0) + 1)
                End If
                values(values.GetUpperBound(0)) = Byte.Parse(currByte, Globalization.NumberStyles.HexNumber)
            Next
 
            mMACAddress = values
        End Set
    End Property
    ''' <summary>
    ''' Total bytes sent by WakeIt method. It is 0 until the method is called at least once for this class instance.
    ''' </summary>
    ''' <returns>Integer value, total bytes trasmitted</returns>
    ''' <remarks></remarks>
    Public ReadOnly Property bytesSent() As Integer
        Get
            Return mBytesSent
        End Get
    End Property
    ''' <summary>
    ''' It represent the Magic Packet broadcasted.
    ''' </summary>
    ''' <returns>String containing the text parsing of the Magic Packet</returns>
    ''' <remarks></remarks>
    Public ReadOnly Property packetSent() As String
        Get
            Return mPacketSent
        End Get
    End Property
    ''' <summary>
    ''' Creates a WOL Magic Packet, the datagram that will awake the target PC updon broadcast on the network.
    ''' </summary>
    ''' <param name="macAddress">An array of byte representing the target machine Network Interface Card MAC address</param>
    ''' <returns>An array of byte representing the Magic Packet</returns>
    ''' <remarks>This method can be used indipendently from the rest of the class. If necessary it can create a Magic Packet just providing the MAC address.</remarks>
    Public Function magicPacket(ByVal macAddress As Byte()) As Byte()
        Dim payloadData As Byte()
        Dim packet As New StringBuilder
 
        Try
            ReDim payloadData(lenHeader + lenMAC * repMAC)
 
            For i As Integer = 0 To lenHeader - 1
                payloadData(i) = Byte.Parse("FF", Globalization.NumberStyles.HexNumber)
            Next
            For i As Integer = 0 To repMAC - 1
                For j As Integer = 0 To lenMAC - 1
                    payloadData(lenHeader + i * lenMAC + j) = macAddress(j)
                Next
            Next
 
            For Each currLoad As Byte In payloadData
                packet.Append("-")
                packet.Append(currLoad.ToString("X2"))
            Next
 
            mPacketSent = packet.ToString.Substring(1)
        Catch ex As Exception
            mPacketSent = "EXCEPTION: " & ex.ToString
        End Try
 
        Return payloadData
    End Function
 
    Function sendUDP(ByVal payload As Byte(), ByVal endPoint As IPEndPoint) As Integer
        Dim byteSend As Integer
        Dim socketClient As Socket
 
        If (payload IsNot Nothing) AndAlso (endPoint IsNot Nothing) Then
            socketClient = New Socket(endPoint.AddressFamily, SocketType.Dgram, ProtocolType.Udp)
            socketClient.Connect(endPoint)
            byteSend = socketClient.Send(payload, 0, payload.Length, SocketFlags.None)
 
            socketClient.Close()
        Else
            byteSend = 0
        End If
 
        Return byteSend
    End Function
    ''' <summary>
    ''' It is the main method of the class. It must be called after the MAC address has been set. It does not return any code, you can see the result of the operation with the bytesSent and packetSent properties of this class.
    ''' </summary>
    ''' <remarks></remarks>
    Public Sub wakeIt()
        mBytesSent = sendUDP(magicPacket(mMACAddress), mEndPoint)
    End Sub
    ''' <summary>
    ''' No parameter is required. The new statement just created the IPEndPoint object.
    ''' </summary>
    ''' <remarks>The default IPEndPoint transmit on port 7. Other choices for WOL are port 0 or 9</remarks>
    Sub New()
        mEndPoint = New IPEndPoint(IPAddress.Broadcast, 7)
    End Sub
    ''' <summary>
    ''' The IPEndPoint object is created to the specified port
    ''' </summary>
    ''' <param name="epPort">A valid port number</param>
    ''' <remarks>If the port number is invalid, the IPEndPoint is created to port 7. Ports normally used for WOL are 0, 7 or 9.</remarks>
    Sub New(ByVal epPort As Integer)
        If epPort >= 0 AndAlso epPort < 65535 Then
            mEndPoint = New IPEndPoint(IPAddress.Broadcast, epPort)
        Else
            mEndPoint = New IPEndPoint(IPAddress.Broadcast, 7)
        End If
    End Sub
End Class

vb.net
1
2
3
4
5
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim WOL As New clsWOL
        WOL.macAddress = "00-30-05-84-03-76"
        WOL.wakeIt()
    End Sub
4
Памирыч
Почетный модератор
20839 / 8721 / 1079
Регистрация: 11.04.2010
Сообщений: 11,012
01.01.2012, 21:54  [ТС] #22
Небольшие вопросы на разную тематику

Разделение Gif-файла на кадры с сохранением в папку (автор кода eJ_Studio)
Разделение Gif-файла на кадры с сохранением в папку (автор кода eJ_Studio)
vb.net
1
2
3
4
5
6
7
        Dim Im As Bitmap = Image.FromFile("C:\1.gif")
        Dim tmpIm_ As New Imaging.FrameDimension(Im.FrameDimensionsList(0))
 
        For i As Integer = 0 To Im.GetFrameCount(tmpIm_) - 1
            Im.SelectActiveFrame(tmpIm_, i)
            Im.Save(String.Format("C:\{0}.bmp", i), Imaging.ImageFormat.Bmp)
        Next


Узнать глобально раскладку клавиатуры (автор кода Дмитрий Юпатов)
Узнать глобально раскладку клавиатуры (автор кода Дмитрий Юпатов)
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Imports System.Runtime.InteropServices
Public Class Form1
    <DllImport("user32.dll", SetLastError:=True)> _
   Private Shared Function GetWindowThreadProcessId(<[In]()> ByVal hWnd As IntPtr, <Out(), [Optional]()> ByVal lpdwProcessId As IntPtr) As Integer
    End Function
    <DllImport("user32.dll", SetLastError:=True)> _
    Private Shared Function GetForegroundWindow() As IntPtr
    End Function
    <DllImport("user32.dll", SetLastError:=True)> _
    Private Shared Function GetKeyboardLayout(<[In]()> ByVal idThread As Integer) As UShort
    End Function
    Private Function GetKeyboardLayout() As UShort
        Return GetKeyboardLayout(GetWindowThreadProcessId(GetForegroundWindow(), IntPtr.Zero))
    End Function
    Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        Label1.Text = GetKeyboardLayout()
    End Sub
End Class


Узнать и установить раскладку для нашего приложения. Информация об установленных языках (автор кода Дмитрий Юпатов)
Узнать и установить раскладку для нашего приложения. Информация об установленных языках (автор кода Дмитрий Юпатов)
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        'Устанавливаем русскую раскладку
        System.Windows.Forms.InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(System.Globalization.CultureInfo.GetCultureInfo(1049))
        Info()
    End Sub
 
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        'Устанавливаем английскую раскладку
        System.Windows.Forms.InputLanguage.CurrentInputLanguage = InputLanguage.FromCulture(System.Globalization.CultureInfo.GetCultureInfo(1033))
        Info()
    End Sub
 
    Sub Info() 'Отображаем текущую раскладку для нашего окна и установленные языки
        Me.Label1.Text = "Активная раскладка: " & System.Windows.Forms.InputLanguage.CurrentInputLanguage.LayoutName
        Me.Label1.Text = Me.Label1.Text & vbCrLf & "Активный язык ввода: " & System.Windows.Forms.InputLanguage.CurrentInputLanguage.Culture.NativeName
        Me.Label1.Text = Me.Label1.Text & vbCrLf & vbCrLf & "Установленные языки:"
        For Each IL As System.Windows.Forms.InputLanguage In System.Windows.Forms.InputLanguage.InstalledInputLanguages
            Me.Label1.Text = Me.Label1.Text & vbCrLf & IL.Culture.NativeName
            Me.Label1.Text = Me.Label1.Text & vbCrLf & IL.Culture.LCID
        Next
    End Sub


Вступление изменений в реестре в силу без перезагрузки компьютера
Вступление изменений в реестре в силу без перезагрузки компьютера
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
Imports System.Runtime.InteropServices
 
Public Class Form1
    Const SHCNE_ASSOCCHANGED As Long = &H8000000L
    Const SHCNF_IDLIST As UInteger = &H0UI
    <DllImport("shell32.dll", CharSet:=CharSet.Auto, SetLastError:=True)> _
Public Shared Sub SHChangeNotify(ByVal wEventId As UInt32, ByVal uFlags As UInt32, ByVal dwItem1 As IntPtr, ByVal dwItem2 As IntPtr)
 
    End Sub
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, IntPtr.Zero, IntPtr.Zero)
    End Sub


Привести числовой массив к строковому (автор кода SSTREGG)
Привести числовой массив к строковому (автор кода SSTREGG)
vb.net
1
2
        Dim arr As Integer() = New Integer() {10, 56, 5647, 12, 78}
        Dim t = arr.[Select](Function(x) x.ToString()).ToArray()


Извлечь иконки из файлов и библиотек
Извлечь иконки из файлов и библиотек
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
    Private Declare Function ExtractIcon Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Integer, ByVal lpszExeFileName As String, ByVal nIconIndex As Integer) As Integer
 
    Private Sub Button2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button2.Click
        Dim file As String = ("c:\windows\system32\taskmgr.exe") 'Путь к носителю иконок
        Dim IconCount As Integer = ExtractIcon(Me.Handle, file, -1) 'Узнаем количество иконок в файле
        For I As Integer = 0 To IconCount - 1
            Dim ico As Icon = Icon.FromHandle(ExtractIcon(Me.Handle, file, I))
            Me.Icon = ico 'Показываем 
            PictureBox1.BackgroundImage = ico.ToBitmap 'Показываем
            If MsgBox("Следующая?", MsgBoxStyle.Question + MsgBoxStyle.YesNo) = MsgBoxResult.No Then Exit Sub
        Next
    End Sub
В данном примере рассматривается исполняемый файл taskmgr.exe, разумеется, путь можно указать и к библиотеке, например, shell32.dll

Если нам нужна иконка файла, можно использовать простой код:
vb.net
1
2
        Dim ico As Icon = Icon.ExtractAssociatedIcon("C:\WINDOWS\system32\spider.exe")
        Me.Icon = ico
Здесь мы получим изображение иконки файла независимо от расширения, именно ту, которую мы видим в проводнике. Это может быть исполняемый файл, библиотека, кника Excel, текстовый документ или вовсе файл без расширения
13
Юпатов Дмитрий
1612 / 1124 / 224
Регистрация: 23.12.2010
Сообщений: 1,495
12.01.2012, 22:37 #23
Рассмотрим на примере надстройки Excel 2007. Создадим простейшую надстройку, которая при запуске создает Вкладку на ленте, группу для элементов управления на вкладке и размещает в группе 2 кнопки.
При нажатии на кнопки отображаются сообщения (см. рис.1).
Итак, приступим.
В окне выбора проекта для создания выбираем "Другие типы проектов">"Общая надстройка" и далее следуем указаниям мастера создания в студии (см. рис.2)
В итоге мы получим решение, включающее в себя 2 проекта: собственно, надстройку и ее установщик. Перво-наперво в проекте установки переходим к редактору реестра и правим там согласно рис.3.
Дело в том, что если оставить как есть, то надстройка нормально стартует только на той машине, где компилилась. Такой вот баг...
Теперь переходим к проекту надстройки. Добавляем недостающие ссылки в него (см. рис.4)

Добавляем в ресурсы xml файл. Я его назвал SimpleExcelAddinRibbon
Он содержит описание вкладки на ленте для нашей надстройки
Листинг файла SimpleExcelAddinRibbon.xml
XML
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"
          xmlns:x = "SimpleExcelAddinRibbon_namespace"
          onLoad="Ribbon_Load"
          loadImage="GetImages">
  <ribbon>
    <tabs>
      <tab idQ="x:MyTab" label="MyTab">
        <group id="SimpleExcelAddinRibbon" label="SimpleExcelAddinRibbon">
          <button id="btnTest1"
                  supertip="Суперподсказка1"
                  label="Тест1"
                  size="large"
                  image="Test1Img"
                  onAction="onAction"/>
          <button id="btnTest2"
                  supertip="Суперподсказка2"
                  label="Тест2"
                  size="large"
                  image="Test2Img"
                  onAction="onAction"/>
          <dialogBoxLauncher>
            <button id="btnDialogBoxLauncher"
                    label="О программе"
                    supertip="Информация о надстройке SimpleExcelAddinRibbon"
                    onAction="onAction"/>
          </dialogBoxLauncher>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

Добавляем в ресурсы также пару картинок (можно png с прозрачностью 128х128), которые будут отображаться на кнопках, я их назвал Test1Img и Test2Img.
В целом, можно в ресурсы и не добавлять, а включить в дистрибут файлы и читать оттуда в рантайме
Далее, создаем новый класс с именем ConvertImage. В нем будет только одна функция, которая картинку переводит в структуру IPictureDisp, которую понимает офис.
Листинг класса ConvertImage.vb
vb.net
1
2
3
4
5
6
7
Imports System.ServiceProcess
Public Class ConvertImage
    Inherits System.Windows.Forms.AxHost
    Public Shared Function Convert(ByVal Image As System.Drawing.Image) As stdole.IPictureDisp
        Convert = GetIPictureFromPicture(Image)
    End Function
End Class
Теперь открываем созданный автоматически класс Connect и правим его:
Листинг класса Connect.vb
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
Imports Extensibility
Imports System.Runtime.InteropServices
Imports Microsoft.Office.Core
 
<GuidAttribute("ADCAAEE8-E111-4419-93B2-6F8A9447648F"), ProgIdAttribute("SimpleExcelAddin.Connect")> _
Public Class Connect
 
    Implements Extensibility.IDTExtensibility2, Microsoft.Office.Core.IRibbonExtensibility
    Dim WithEvents applicationObject As Microsoft.Office.Interop.Excel.Application
    Dim addInInstance As Object
    Friend ribbonX As Microsoft.Office.Core.IRibbonUI
 
    Public Sub OnBeginShutdown(ByRef custom As System.Array) Implements Extensibility.IDTExtensibility2.OnBeginShutdown
        ' Функция создается автоматом, естественно пустая :)
    End Sub
 
    Public Sub OnAddInsUpdate(ByRef custom As System.Array) Implements Extensibility.IDTExtensibility2.OnAddInsUpdate
        ' Функция создается автоматом, естественно пустая :)
        ' происходит при установке более новой версии
    End Sub
 
    Public Sub OnStartupComplete(ByRef custom As System.Array) Implements Extensibility.IDTExtensibility2.OnStartupComplete
        ' Функция создается автоматом, естественно пустая :)
        ' происходит по окончании старта
    End Sub
 
    Public Sub OnDisconnection(ByVal RemoveMode As Extensibility.ext_DisconnectMode, ByRef custom As System.Array) Implements Extensibility.IDTExtensibility2.OnDisconnection
        ' Функция создается автоматом, естественно пустая :)
        ' происходит при рассоединении надстройки с Экселем
    End Sub
 
    Public Sub OnConnection(ByVal application As Object, ByVal connectMode As Extensibility.ext_ConnectMode, ByVal addInInst As Object, ByRef custom As System.Array) Implements Extensibility.IDTExtensibility2.OnConnection
        ' Функция создается автоматом, естественно пустая :)
        ' происходит при соединении надстройки с Экселем
        applicationObject = application
        addInInstance = addInInst
        If (connectMode <> Extensibility.ext_ConnectMode.ext_cm_Startup) Then
            Call OnStartupComplete(custom)
        End If
    End Sub
 
    Function GetCustomUI(ByVal CustomUI As String) As String Implements IRibbonExtensibility.GetCustomUI
        ' эта функция загрузит нашу вкладку на ленту. Функция набирается ручками
        Return My.Resources.SimpleExcelAddinRibbon
    End Function
 
    ' все что ниже набрано ручками
    Public Sub Ribbon_Load(ByVal ribbon As IRibbonUI)
        ' эта процедура упомянута в xml файле. Тут мы загоняем отрисованную для нас вкладку в переменную
        ribbonX = ribbon
    End Sub
 
    Public Sub onAction(ByVal control As IRibbonControl)
        ' выполняется при нажатии кнопки. Одна процедура может быть использована для нескольких контролов. А можно и разные, главное правильно указать имя процедуры для свойства контрола в xml файле. И обязательно Public, иначе не вызовется
        Select Case control.Id
            Case "btnTest1"
                Button1Click()
            Case "btnTest2"
                Button2Click()
            Case "btnDialogBoxLauncher"
                btnDialogBoxLauncherClick()
        End Select
    End Sub
 
    Private Function getImage(ByVal image As System.Drawing.Image) As stdole.IPictureDisp
        Dim tempImage As stdole.IPictureDisp = Nothing
        Try
            tempImage = ConvertImage.Convert(image)
        Catch ex As Exception
        End Try
        Return tempImage
    End Function
 
 
    Public Function GetImages(ByVal image_id As String) As stdole.IPictureDisp
        ' функция задаст картинки для кнопок. См. xml, там она упомянута. И обязательно Public, иначе не вызовется
        Select Case image_id
            Case "Test1Img"
                Return Me.getImage(My.Resources.Test1Img)
            Case "Test2Img"
                Return Me.getImage(My.Resources.Test2Img)
        End Select
    End Function
 
    ' ну и процедуры, выполняющиеся при нажатиях
    Private Sub Button1Click()
        MsgBox("Нажали кнопку1")
    End Sub
    Private Sub Button2Click()
        MsgBox("Нажали кнопку2")
    End Sub
    Private Sub btnDialogBoxLauncherClick()
        MsgBox("Нажали уголок внизу группы")
    End Sub
 
End Class

Ну... в коде даны пояснения в комментариях.
Чтобы потестить надо:
  1. Скомпилить библиотеку.
  2. Скомпилить дистрибут
  3. установить дистрибут
  4. Запустить Эксель.
Дальше можно будет править код и перекомпилить библиотеку. При этом дистрибут можно не трогать, изменения должны вноситься и так. Следите только, чтоб при компиляции надстройки Эксель не был запущен.

Надстройка видна в списке таких же в Экселе (рис.5). Удаляется через "Установку и удаление программ", где она видна под именем проекта установки.

P.S.
Создание сборки для более ранних версий отличается только наличием кода создания панели инструментов и контролов на ней. Ну и плюс, если надстройка универсальная - перед созданием панели проверяем номер версии экселя: если 11 или меньше - панель надо (версия не более 2003), если 12 или больше - панель не надо, имеем 2008 или старше.

Полный архив с тестовой надстройкой прилагается к посту.

Добавлю: при создании проекта надстройки с целевой версией .NetFramework версии 2.0 нужно также скачать и установить заплатку от Microsoft, которая это исправляет. Также ее надо будет подключать к проекту установки, т.е. вносить в список необходимых компонентов.
При распространении дистрибута надо будет распространять весть комплект, который создается в папке bin проекта установщика (файлы msi, exe и папка с установщиком заплатки) и установку производить через запуск файла msi для автоустановки заплатки на конечной машине.
Зачем нужна эта заплатка? Потому что надстройка работает только на той машине, где компилилась. Заплатка этот баг устраняет.
Ну а если речь идет о версии .NetFramework 3.0 или старше, то все в порядке, заплата не нужна.

Кроме того, надстройки можно создавать с помощью инструментария MS Visual Studio Tools For Office. Что касается работы с лентой, там все намного удобнее - можно работать визуально, а можно открыть xml.

Кроме того, дополнительно о ленте можно почитать тут и тут.
Ну и погуглить по словам Fluent Ribbon

Добавлено через 22 минуты
Вот! Нашел наконец-то довольно ценную статью от Microsoft. Охватывает и ленту и создание AddIn. Читаем
9
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды  

Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды  

Вложения
Тип файла: rar SimpleExcelAddin.rar (1.00 Мб, 162 просмотров)
SergKr
65 / 39 / 3
Регистрация: 07.12.2010
Сообщений: 327
26.03.2012, 17:19 #24
Печать RichTextBox на принтере с сохранением форматирования
Новый проект. На нём только кнопка.
Проект -> Добавить класс...
Имя класса пишем RichTextBoxPrintCtrl
Вставляем код:

Класс компонента
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
Option Explicit On
 
Imports System
Imports System.Windows.Forms
Imports System.Drawing
Imports System.Runtime.InteropServices
Imports System.Drawing.Printing
 
Namespace RichTextBoxPrintCtrl
    Public Class RichTextBoxPrintCtrl
        Inherits RichTextBox
 
        ' Convert the unit that is used by the .NET framework 
        ' (1/100 inch) and the unit that is used by Win32 API calls  
        ' (twips 1/1440 inch)
        Private Const AnInch As Double = 14.4
 
        Private WithEvents m_PrintDocument As Printing.PrintDocument
        Private intCharactersToPrint As Integer
        Private intCurrentPosition As Integer
 
        <StructLayout(LayoutKind.Sequential)> _
        Private Structure RECT
            Public Left As Integer
            Public Top As Integer
            Public Right As Integer
            Public Bottom As Integer
        End Structure
 
        <StructLayout(LayoutKind.Sequential)> _
        Private Structure CHARRANGE
            ' First character of range (0 for start of doc)
            Public cpMin As Integer
            ' Last character of range (-1 for end of doc)
            Public cpMax As Integer
        End Structure
 
        <StructLayout(LayoutKind.Sequential)> _
        Private Structure FORMATRANGE
            ' Actual DC to draw on
            Public hdc As IntPtr
            ' Target DC for determining text formatting
            Public hdcTarget As IntPtr
            ' Region of the DC to draw to (in twips)
            Public rc As Rect
            ' Region of the whole DC (page size) (in twips)
            Public rcPage As Rect
            ' Range of text to draw (see above declaration)
            Public chrg As CHARRANGE
        End Structure
 
        Private Const WM_USER As Integer = &H400
        Private Const EM_FORMATRANGE As Integer = WM_USER + 57
 
        Private Declare Function SendMessage Lib "USER32" Alias _
            "SendMessageA" (ByVal hWnd As IntPtr, ByVal msg As Integer, _
            ByVal wp As IntPtr, ByVal lp As IntPtr) As IntPtr
 
        Public Sub SelPrint()
 
            'print only the selected text if any is selected
            If Me.SelectionLength > 0 Then
                intCharactersToPrint = Me.SelectionStart + Me.SelectionLength
                intCurrentPosition = Me.SelectionStart
            Else
                'otherwise print the entire document
                intCharactersToPrint = Me.TextLength
                intCurrentPosition = 0
            End If
 
            m_PrintDocument.Print()
 
        End Sub
        ' Render the contents of the RichTextBox for printing
        ' Return the last character printed + 1 (printing start from 
        ' this point for next page)
        Private Function Print(ByVal charFrom As Integer, _
ByVal charTo As Integer, ByVal e As PrintPageEventArgs) As Integer
 
            ' Mark starting and ending character
            Dim cRange As CHARRANGE
            cRange.cpMin = charFrom
            cRange.cpMax = charTo
 
            ' Calculate the area to render and print
            Dim rectToPrint As RECT
            rectToPrint.Top = e.MarginBounds.Top * AnInch
            rectToPrint.Bottom = e.MarginBounds.Bottom * AnInch
            rectToPrint.Left = e.MarginBounds.Left * AnInch
            rectToPrint.Right = e.MarginBounds.Right * AnInch
 
            ' Calculate the size of the page
            Dim rectPage As RECT
            rectPage.Top = e.PageBounds.Top * AnInch
            rectPage.Bottom = e.PageBounds.Bottom * AnInch
            rectPage.Left = e.PageBounds.Left * AnInch
            rectPage.Right = e.PageBounds.Right * AnInch
 
            Dim hdc As IntPtr = e.Graphics.GetHdc()
 
            Dim fmtRange As FORMATRANGE
            ' Indicate character from to character to
            fmtRange.chrg = cRange
            ' Use the same DC for measuring and rendering
            fmtRange.hdc = hdc
            ' Point at printer hDC
            fmtRange.hdcTarget = hdc
            ' Indicate the area on page to print
            fmtRange.rc = rectToPrint
            ' Indicate whole size of page
            fmtRange.rcPage = rectPage
 
            Dim res As IntPtr = IntPtr.Zero
 
            Dim wparam As IntPtr = IntPtr.Zero
            wparam = New IntPtr(1)
 
            ' Move the pointer to the FORMATRANGE structure in 
            ' memory
            Dim lparam As IntPtr = IntPtr.Zero
            lparam = _
Marshal.AllocCoTaskMem(Marshal.SizeOf(fmtRange))
            Marshal.StructureToPtr(fmtRange, lparam, False)
 
            ' Send the rendered data for printing
            res = _
SendMessage(Handle, EM_FORMATRANGE, wparam, lparam)
 
            ' Free the block of memory allocated
            Marshal.FreeCoTaskMem(lparam)
 
            ' Release the device context handle obtained by a 
            ' previous call
            e.Graphics.ReleaseHdc(hdc)
 
            'return the last + 1 character printed
            Return res.ToInt32
 
        End Function
        Public ReadOnly Property PrintDocument() As Printing.PrintDocument
            Get
                If m_PrintDocument Is Nothing Then
                    m_PrintDocument = New Printing.PrintDocument
                End If
 
                Return m_PrintDocument
            End Get
        End Property
 
        Private Sub m_PrintDocument_PrintPage(ByVal sender As _
Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs) _
Handles m_PrintDocument.PrintPage
            ' Print the content of the RichTextBox. 
            ' Store the last character printed.
 
            intCurrentPosition = Me.Print(intCurrentPosition, _
intCharactersToPrint, e)
 
            ' Look for more pages by checking 
            If intCurrentPosition < intCharactersToPrint Then
                e.HasMorePages = True
            Else
                e.HasMorePages = False
            End If
 
        End Sub
    End Class
End Namespace
Теперь на форме добавляем: RichTextBoxPrintCtrl
Кидаем PrintDialog на форму.
В кнопку пишем код:
vb.net
1
2
3
4
5
PrintDialog1.Document = Me.RichTextBoxPrintCtrl1.PrintDocument
 
        If PrintDialog1.ShowDialog() = DialogResult.OK Then
            Me.RichTextBoxPrintCtrl1.SelPrint()
        End If
9
Russiablackbird
61 / 61 / 1
Регистрация: 23.01.2012
Сообщений: 254
30.03.2012, 09:42 #25
Снчала на форму кинем label1 и labe2 в первом вес файла во 2 скорость скачивания и ещё progressbar для показа степени загрузки файла ,BackgroundWorker и кнопку .
Теперь перейдём к коду
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
Imports System.Net
Public Class mainForm
 
    Dim whereToSave As String 'Where the program save the file
 
    Delegate Sub ChangeTextsSafe(ByVal length As Long, ByVal position As Integer, ByVal percent As Integer, ByVal speed As Double)
    Delegate Sub DownloadCompleteSafe(ByVal cancelled As Boolean)
 
    Public Sub DownloadComplete(ByVal cancelled As Boolean)
        Me.Button1.Enabled = True
        If cancelled Then
 
 
            MessageBox.Show("Обновление отменено", "Отмена", MessageBoxButtons.OK, MessageBoxIcon.Information)
 
 
        Else
 
            MessageBox.Show("Обновление завершено", "Ок", MessageBoxButtons.OK, MessageBoxIcon.Information)
 
 
        End If
 
        Me.ProgressBar1.Value = 0
        Me.Label1.Text = "Размер файла: "
        Me.Label2.Text = "Скорость загрузки: "
 
    End Sub
 
    Public Sub ChangeTexts(ByVal length As Long, ByVal position As Integer, ByVal percent As Integer, ByVal speed As Double)
 
        Me.Label1.Text = "Размер файла: " & Math.Round((length / 1024), 2) & " Кб"
 
 
        If speed = -1 Then
            Me.Label2.Text = "Подсчёт скорости"
        Else
            Me.Label2.Text = "Скорость: " & Math.Round((speed / 1024), 2) & " Кб/с"
        End If
 
        Me.ProgressBar1.Value = percent
 
 
    End Sub
 
    Private Sub btnDownload_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
 
        Me.Button1.Enabled = False
        Me.BackgroundWorker1.RunWorkerAsync() 'Начинаем загрузку
    End Sub
 
    Private Sub BackgroundWorker1_DoWork(ByVal sender As System.Object, ByVal e As System.ComponentModel.DoWorkEventArgs) Handles BackgroundWorker1.DoWork
 
        Dim theResponse As HttpWebResponse
        Dim theRequest As HttpWebRequest
        Try
 
            theRequest = WebRequest.Create("http://globalmods.16mb.com/Test.zip")
            theResponse = theRequest.GetResponse
        Catch ex As Exception
 
            MessageBox.Show("An error occurred while downloading file. Possibe causes:" & ControlChars.CrLf & _
                            "1) File doesn't exist" & ControlChars.CrLf & _
                            "2) Remote server error", "Error", MessageBoxButtons.OK, MessageBoxIcon.Error)
 
            Dim cancelDelegate As New DownloadCompleteSafe(AddressOf DownloadComplete)
 
            Me.Invoke(cancelDelegate, True)
 
            Exit Sub
        End Try
        Dim length As Long = theResponse.ContentLength
 
        Dim safedelegate As New ChangeTextsSafe(AddressOf ChangeTexts)
        Me.Invoke(safedelegate, length, 0, 0, 0)
 
        Dim writeStream As New IO.FileStream("C:\Users\Alexandr\Desktop\minecraft.rar", IO.FileMode.Create)
 
 
        Dim nRead As Integer
 
 
        Dim speedtimer As New Stopwatch
        Dim currentspeed As Double = -1
        Dim readings As Integer = 0
 
        Do
 
            If BackgroundWorker1.CancellationPending Then
                Exit Do
            End If
 
            speedtimer.Start()
 
            Dim readBytes(4095) As Byte
            Dim bytesread As Integer = theResponse.GetResponseStream.Read(readBytes, 0, 4096)
 
            nRead += bytesread
            Dim percent As Short = nRead / length * 100
 
            Me.Invoke(safedelegate, length, nRead, percent, currentspeed)
 
            If bytesread = 0 Then Exit Do
 
            writeStream.Write(readBytes, 0, bytesread)
 
            speedtimer.Stop()
 
            readings += 1
            If readings >= 5 Then
                currentspeed = 20480 / (speedtimer.ElapsedMilliseconds / 1000)
                speedtimer.Reset()
                readings = 0
            End If
        Loop
 
 
        theResponse.GetResponseStream.Close()
        writeStream.Close()
 
        If Me.BackgroundWorker1.CancellationPending Then
 
            IO.File.Delete(Me.whereToSave)
 
            Dim cancelDelegate As New DownloadCompleteSafe(AddressOf DownloadComplete)
 
            Me.Invoke(cancelDelegate, True)
 
            Exit Sub
 
        End If
 
        Dim completeDelegate As New DownloadCompleteSafe(AddressOf DownloadComplete)
 
        Me.Invoke(completeDelegate, False)
 
    End Sub
 
    Private Sub Label3_Click(sender As System.Object, e As System.EventArgs) Handles Label1.Click
 
    End Sub
 
    Private Sub mainForm_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
 
    End Sub
End Class
8
вадим2
91 / 91 / 3
Регистрация: 01.12.2011
Сообщений: 94
02.04.2012, 19:27 #26
Сегодня решил написать о скриншотах, а именно: как сфотографировать окно по заголовку, как сфотографировать объект system.windows.forms, сфотографировать рабочий стол и рабочий стол с панелью задач.
фотографирование окна по заголовку

Класс для работы
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
Imports System.Runtime.InteropServices
Public Class СкриншотОкнаПоЗаголовку
    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
 Private Shared Function FindWindow( _
      ByVal lpClassName As String, _
      ByVal lpWindowName As String) As IntPtr
    End Function
    Public Shared Function FindWindow1(ByVal windowName As String, ByVal wait As Boolean) As Integer
        Dim hWnd As Integer = FindWindow(Nothing, windowName)
        While wait AndAlso hWnd = 0
            System.Threading.Thread.Sleep(500)
            hWnd = FindWindow(Nothing, windowName)
        End While
        Return hWnd
    End Function
    Function скрин_отдельного_окна(ByVal заголовок_окна As String) As Image
        Return CaptureWindow(FindWindow1(заголовок_окна, False))
    End Function
    Public Shared Function CaptureWindow(ByVal WindowHandle As IntPtr) As Image
 
        Dim windowRect As New User32.RECT()
        User32.GetWindowRect(WindowHandle, windowRect)
        Dim width As Integer = windowRect.right - windowRect.left + 1
        Dim height As Integer = windowRect.bottom - windowRect.top + 1
 
        User32.SetWindowPos(WindowHandle, CType(User32.HWND_TOPMOST, System.IntPtr), 0, 0, 0, 0, _
         User32.SWP_NOMOVE Or User32.SWP_NOSIZE Or User32.SWP_FRAMECHANGED)
 
        Dim hdcSrc As IntPtr = User32.GetWindowDC(WindowHandle)
        Dim hdcDest As IntPtr = GDI32.CreateCompatibleDC(hdcSrc)
 
        Dim hBitmap As IntPtr = GDI32.CreateCompatibleBitmap(hdcSrc, width, height)
 
        Dim hOld As IntPtr = GDI32.SelectObject(hdcDest, hBitmap)
 
        GDI32.BitBlt(hdcDest, 0, 0, width, height, hdcSrc, _
         0, 0, GDI32.SRCCOPY)
 
        User32.SetWindowPos(WindowHandle, CType(User32.HWND_NOTOPMOST, System.IntPtr), 0, 0, 0, 0, _
         User32.SWP_NOMOVE Or User32.SWP_NOSIZE Or User32.SWP_FRAMECHANGED)
 
        GDI32.SelectObject(hdcDest, hOld)
        GDI32.DeleteDC(hdcDest)
        User32.ReleaseDC(WindowHandle, hdcSrc)
        Dim img As Image = Image.FromHbitmap(hBitmap)
        GDI32.DeleteObject(hBitmap)
        Return img
    End Function
    Private Class User32
 
        Public Const SWP_FRAMECHANGED As Integer = &H20
        Public Const SWP_NOMOVE As Integer = &H2
        Public Const SWP_NOSIZE As Integer = &H1
        Public Const SWP_NOZORDER As Integer = &H4
        Public Const HWND_TOPMOST As Integer = -1
        Public Const HWND_NOTOPMOST As Integer = -2
 
        <StructLayout(LayoutKind.Sequential)> _
        Public Structure RECT
            Public left As Integer
            Public top As Integer
            Public right As Integer
            Public bottom As Integer
        End Structure
 
        <DllImport("user32.dll")> _
        Public Shared Function GetWindowDC(ByVal hWnd As IntPtr) As IntPtr
        End Function
 
        <DllImport("user32.dll")> _
        Public Shared Function ReleaseDC(ByVal hWnd As IntPtr, ByVal hDC As IntPtr) As IntPtr
        End Function
 
        <DllImport("user32.dll")> _
        Public Shared Function GetWindowRect(ByVal hWnd As IntPtr, ByRef rect As RECT) As IntPtr
        End Function
 
        <DllImport("user32.dll", SetLastError:=True)> _
        Public Shared Function SetWindowPos(ByVal hWnd As IntPtr, ByVal hWndInsertAfter As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal cx As Integer, ByVal cy As Integer, _
         ByVal uFlags As UInteger) As <MarshalAs(UnmanagedType.Bool)> Boolean
        End Function
    End Class
    Private Class GDI32
 
        Public Const SRCCOPY As Integer = &HCC0020
 
        <DllImport("gdi32.dll")> _
        Public Shared Function BitBlt(ByVal hObject As IntPtr, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hObjectSource As IntPtr, _
         ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As Integer) As Boolean
        End Function
 
        <DllImport("gdi32.dll")> _
        Public Shared Function CreateCompatibleBitmap(ByVal hDC As IntPtr, ByVal nWidth As Integer, ByVal nHeight As Integer) As IntPtr
        End Function
 
        <DllImport("gdi32.dll")> _
        Public Shared Function CreateCompatibleDC(ByVal hDC As IntPtr) As IntPtr
        End Function
 
        <DllImport("gdi32.dll")> _
        Public Shared Function DeleteDC(ByVal hDC As IntPtr) As Boolean
        End Function
 
        <DllImport("gdi32.dll")> _
        Public Shared Function DeleteObject(ByVal hObject As IntPtr) As Boolean
        End Function
 
        <DllImport("gdi32.dll")> _
        Public Shared Function SelectObject(ByVal hDC As IntPtr, ByVal hObject As IntPtr) As IntPtr
        End Function
    End Class
End Class


Пример использования этого класса
vb.net
1
2
3
4
5
6
Dim классскрина As New СкриншотОкнаПоЗаголовку
        If TextBox1.Text = Nothing Then
            MsgBox("а заголовок где?")
        Else
            PictureBox1.Image = классскрина.скрин_отдельного_окна(TextBox1.Text)
        End If
скриншот обьекта system.windows.forms
функция для фотографирования
vb.net
1
2
3
4
5
6
7
8
9
    Function скрин_объект(ByVal obj As System.Windows.Forms.Control)
        Dim bmp As New Bitmap(obj.Width, obj.Height)
        obj.DrawToBitmap(bmp, New Rectangle(New Point(0, 0), obj.Size))
        Dim loc As Point = New Point(0, 0)
        bmp = bmp.Clone(New Rectangle(loc, obj.Size), Imaging.PixelFormat.Undefined)
        Dim a = IO.Path.GetTempFileName.Replace(".tmp", ".jpg")
        bmp.Save(a)
        Return a
    End Function
Пример использования
vb.net
1
2
3
PictureBox1.ImageLocation = скрин_объект(Button1)
PictureBox1.ImageLocation = скрин_объект(Me)
'и так можно любой объект
скриншот рабочего стола
функции использования
для фотографирования только экрана
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
Function скрин() As String
        Dim fileName As String
        fileName = My.Computer.FileSystem.GetTempFileName()
        Dim sw, sh As Integer
        sw = My.Computer.Screen.WorkingArea.Size.Width
        sh = My.Computer.Screen.WorkingArea.Size.Height
        Dim scrpic As New System.Drawing.Bitmap(sw, sh)
        Dim gscrpic As Graphics = Graphics.FromImage(scrpic)
        gscrpic.Clear(Color.FromArgb(13, 11, 12))
        gscrpic.CopyFromScreen(New Point(0, 0), New Point(0, 0), New Size(sw, sh))
        scrpic.Save(fileName, Imaging.ImageFormat.Bmp) ' ВНИМАНИЕ!! тут формат рисунка
        Return fileName
    End Function
для фотографирования экрана и панели задач
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
 Function скрин_с_панелью_задач() As String
        Dim fileName As String
        fileName = My.Computer.FileSystem.GetTempFileName()
        Dim sw, sh As Integer
        sw = My.Computer.Screen.Bounds.Size.Width
        sh = My.Computer.Screen.Bounds.Size.Height
        Dim scrpic As New System.Drawing.Bitmap(sw, sh)
        Dim gscrpic As Graphics = Graphics.FromImage(scrpic)
        gscrpic.Clear(Color.FromArgb(13, 11, 12))
        gscrpic.CopyFromScreen(New Point(0, 0), New Point(0, 0), New Size(sw, sh))
        scrpic.Save(fileName, Imaging.ImageFormat.Bmp) ' ВНИМАНИЕ!! тут формат рисунка
        Return fileName
    End Function
пример использования
vb.net
1
2
3
4
'для экрана
PictureBox1.ImageLocation = скрин()
'для экрана и панели задач
 PictureBox1.ImageLocation = скрин_с_панелью_задач()
Во влажениях эти примеры.
Вот и всё. Спасибо за внимание!
10
Вложения
Тип файла: zip скиншот объекта.zip (100.1 Кб, 239 просмотров)
Тип файла: zip Скриншот по заголовку.zip (71.8 Кб, 145 просмотров)
Тип файла: zip скриншот рабочего стола.zip (103.3 Кб, 143 просмотров)
вадим2
91 / 91 / 3
Регистрация: 01.12.2011
Сообщений: 94
11.04.2012, 19:41 #27
все мы знаем, как управлять прозрачностью формы:


vb.net
1
Me.Opacity = 1

однако это не та прозрачность, просмотрите во вложениях скриншот формы, код:


vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Imports System.Runtime.InteropServices
Public Class Form1
<Runtime.InteropServices.StructLayout(Runtime.InteropServices.LayoutKind.Sequential)> Public Structure MARGINS
        Public LeftWidth As Integer
        Public RightWidth As Integer
        Public TopHeight As Integer
        Public Buttomheight As Integer
    End Structure
    <Runtime.InteropServices.DllImport("dwmapi.dll")> Public Shared Function DwmExtendFrameIntoClientArea(ByVal hWnd As IntPtr, ByRef pMarinset As MARGINS) As Integer
    End Function
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Try
            Me.TransparencyKey = Color.Cyan 'контралах не используйте этот цвет, или меняйте
            Me.BackColor = Color.Cyan ''контралах не используйте этот цвет, или меняйте
            Dim margins As MARGINS = New MARGINS
            margins.LeftWidth = -1
            margins.RightWidth = -1
            margins.TopHeight = -1
            margins.Buttomheight = -1
            Dim result As Integer = DwmExtendFrameIntoClientArea(Me.Handle, margins)
        Catch ex As Exception
            MsgBox("ошибика" & Err.Description, vbCritical, "Fatal Error")
            Application.Exit()
        End Try
    End Sub
End Class
24
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды  
Юпатов Дмитрий
1612 / 1124 / 224
Регистрация: 23.12.2010
Сообщений: 1,495
11.05.2012, 13:28 #28
Создание собственного элемента управления
Попробуем создать собственный ProgressBar (известно, что штатный далеко не всегда отвечает требованиям разработчика).
1. Создаем новый проект WindowsForms
2. Добавляем к проекту файл класса с именем UserProgressBar и заполняем его
следующим кодом
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
Public Class UserProgressBar
    Inherits System.Windows.Forms.Control ' наследуем Control
    Dim min As UInteger
    Dim max As UInteger
    Dim CurVal As UInteger
    Dim orient As OrientationEnum
    Dim UText As String
    Dim Pimg As Bitmap
    Dim Gr As Graphics
    Dim Fclr As Color
    Dim WrText As WTenum
    Dim FS As FillStyleEnum
 
#Region "PublicProperties"
    Public Property Minimum() As UInteger
        Get
            Minimum = min
        End Get
        Set(ByVal value As UInteger)
            min = value
            DrawProgress()
        End Set
    End Property
    Public Property Maximum() As UInteger
        Get
            Maximum = max
        End Get
        Set(ByVal value As UInteger)
            max = value
            DrawProgress()
        End Set
    End Property
    Public Property CurrentValue() As UInteger
        Get
            CurrentValue = CurVal
        End Get
        Set(ByVal value As UInteger)
            CurVal = value
            DrawProgress()
        End Set
    End Property
    Public Property ProgressOrientation() As OrientationEnum
        Get
            ProgressOrientation = orient
        End Get
        Set(ByVal value As OrientationEnum)
            orient = value
            DrawProgress()
        End Set
    End Property
    Public Property FillColor() As Color
        Get
            FillColor = Fclr
        End Get
        Set(ByVal value As Color)
            Fclr = value
            DrawProgress()
        End Set
    End Property
    Public Property WrittenText() As WTenum
        Get
            WrittenText = WrText
        End Get
        Set(ByVal value As WTenum)
            WrText = value
            DrawProgress()
        End Set
    End Property
    Public Property FillStyle() As FillStyleEnum
        Get
            FillStyle = FS
        End Get
        Set(ByVal value As FillStyleEnum)
            FS = value
            DrawProgress()
        End Set
    End Property
#End Region
 
#Region "Enums"
    Public Enum OrientationEnum As Integer
        Horisontal = 0
        Vertical = 1
    End Enum
    Public Enum WTenum As Integer
        Text = 0
        Percentage = 1
        PercentageWithSumbol = 2
        PartOfOne = 3
        None = 4
    End Enum
    Public Enum FillStyleEnum As Integer
        Solid = 0
        Texture = 1
    End Enum
#End Region
 
    Public Sub New()
        ' задаем значения по-умолчанию и отрисовываем
        Me.Minimum = 0
        Me.Maximum = 100
        Me.CurrentValue = 0
        Me.WrText = WTenum.PercentageWithSumbol
        Me.ProgressOrientation = OrientationEnum.Horisontal
        Me.Size = New Size(100, 23)
        Me.BackgroundImageLayout = ImageLayout.Stretch
        Me.FillColor = Color.Green
        Me.BackColor = SystemColors.Window
        Me.FillStyle = FillStyleEnum.Solid
        DrawProgress()
    End Sub
 
    Private Sub DrawProgress()
        Try
            Me.Pimg = New Bitmap(Me.Width, Me.Height, Imaging.PixelFormat.Format32bppArgb)
            Gr = Graphics.FromImage(Pimg)
            Gr.CompositingQuality = Drawing2D.CompositingQuality.HighQuality
            Gr.TextRenderingHint = Drawing.Text.TextRenderingHint.AntiAliasGridFit
            ' создаем кисть с учетом стиля заливки и ориентации
            Dim br As Brush
            If Me.FillStyle = FillStyleEnum.Solid Then
                br = New SolidBrush(Me.FillColor)
            Else
                If Me.ProgressOrientation = OrientationEnum.Horisontal Then
                    br = New TextureBrush(My.Resources.h_fillelement)
                Else
                    br = New TextureBrush(My.Resources.v_fillelement)
                End If
            End If
            ' объявляем прясоугольник заполненной области и вычисляем его размеры с учетом состояния свойства ProgressOrientation
            Dim FillRect As Rectangle
            If Me.ProgressOrientation = OrientationEnum.Horisontal Then
                FillRect = New Rectangle(0, 0, CInt(CurVal / max * Me.Width), Me.Height)
            Else
                FillRect = New Rectangle(0, Me.Height - CInt(CurVal / max * Me.Height), Me.Width, CInt(CurVal / max * Me.Height))
            End If
            ' заливаем прямоугольник
            Gr.FillRectangle(br, FillRect)
            ' формируем строку для рисования с учетом свойства WrittenText
            Dim s As String = String.Empty
            Select Case WrittenText
                Case Is = WTenum.None
                    s = String.Empty
                Case Is = WTenum.PartOfOne
                    s = CInt(CurVal / max)
                Case Is = WTenum.Percentage
                    s = CInt(CurVal / max * 100)
                Case Is = WTenum.PercentageWithSumbol
                    s = CInt(CurVal / max * 100) & "%"
                Case Is = WTenum.Text
                    s = Me.Text
            End Select
            ' форматируем строку ( выравнивание - в центр области, поворот - по свойству ProgressOrientation)
            Dim drawformat As New StringFormat
            drawformat.Alignment = StringAlignment.Center
            drawformat.LineAlignment = StringAlignment.Center
            If Me.ProgressOrientation = OrientationEnum.Vertical Then drawformat.FormatFlags = StringFormatFlags.DirectionVertical
            ' рисуем строку
            Gr.DrawString(s, Me.Font, New SolidBrush(Me.ForeColor), New Rectangle(0, 0, Me.Width, Me.Height), drawformat)
            Me.BackgroundImage = Pimg
        Catch
        End Try
    End Sub
 
    ' в этом событии отслеживаются события контрола, при которых нам потребуется его перерисовка
    Private Sub UserProgressBar_Changed(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Resize, Me.ForeColorChanged, Me.FontChanged, Me.BackColorChanged
        Me.Pimg = New Bitmap(Me.Width, Me.Height, Imaging.PixelFormat.Format32bppArgb)
        DrawProgress()
    End Sub
End Class

4. В ресурсы проекта добавляем рисунки, служащие заливкой бара (2шт - для вертикального и горизонтального стилей (имена h_fillelement и v_fillelement соответственно). Рисунки во вложениях №1 и 2)
5. Создаем решение
6. На панели инструментов (если перейти в конструктор формы) мы увидим, что добавлен контрол UserProgressbar
7. Создаем тестоую форму: при создании проекта студия нам добавила пустую форму, вот ею и воспользуемся. Размещаем на форме 4 наших прогрессбара и NumericUpDown
Прогрессбар2 - устанавливаем свойство FillStyle=Texture
Прогрессбар3 - свойство ProgressOrientation=Vertical
Прогрессбар4 - свойства ProgressOrientation=Vertical и FillStyle=Texture
Больше ничего не меняем.
8. Открываем код формы и меняем его
следующим образом
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Public Class Form1
    Private Sub NumericUpDown1_ValueChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles NumericUpDown1.ValueChanged
        Me.UserProgressBar1.CurrentValue = Me.NumericUpDown1.Value
        Me.UserProgressBar2.CurrentValue = Me.NumericUpDown1.Value
        Me.UserProgressBar3.CurrentValue = Me.NumericUpDown1.Value
        Me.UserProgressBar4.CurrentValue = Me.NumericUpDown1.Value
    End Sub
 
    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        With Me.NumericUpDown1
            .Minimum = Me.UserProgressBar1.Minimum
            .Maximum = Me.UserProgressBar1.Maximum
            .Value = Me.UserProgressBar1.CurrentValue
        End With
    End Sub
End Class

9. Запускаем проект нажатием F5. Если все выполнено верно, появится форма (см. вложение №3). Попробуйте менять значения в NumericUpDown1

А теперь немного о коде класса UserProgressBar.
Класс унаследован от Control.
В регионе Enums содержатся перечисления, необходимые для красивого задания свойств нашего контрола:
OrientationEnum - ориентация направления заполнения бара (горизонт и вертикаль)
WTenum - отображаемый текст на контроле (строка из свойства Text, число процентов заливки, число процентов заливки со значком процента, доля заливки (0...1), ничего)
FillStyleEnum - стиль заливки (сплошным цветом или текстурой (вспоминаем о картинках в ресурсах)

В регионе PublicProperties содержатся свойства, которые добавляются нами как недостающие и доступны в панели свойств проекта (см. вложение №4):
Minimum, Maximum, CurrentValue - имеют тип Uinteger (целое не меньше 0 то есть) и думаю, значение их понятно.
ProgressOrientation - ориентация заливки (горизонт и вертикаль)
FillColor - цвет заливки при выбранном стиле заливки Solid
WrittenText - выбор типа отображаемого текста (см. перечисление WTenum)
FillStyle - стиль заливки (см перечисление FillStyleEnum)


Процедура New - выполняется при создании нового экземпляра UserProgressBar (независимо от того, программное создание или в конструкторе). Тут задаются значения по умолчанию для свойств контрола

Процедура DrawProgress - вот она и рисует полосу прогресса с учетом свойств. Обратите внимание, что для немедленной перерисовки процедура вызывается в каждом свойстве (см. код региона PublicProperties)
Процедура UserProgressBar_Changed - тут также вызывается перерисовка прогресса при некоторых унаследованных событиях. В данном случае это происходит при изменении размера, смены цвета подложки, и цвета шрифта, типа шрифта. Все это также повышает удобство пользования.

Ну и напоследок: Для изменения шрифта текста, который отрисовывается на баре используются свойства контрола Font и ForeColor, при установленном в позицию Text свойстве WrittenText рисуется строка из свойства Text элемента управления.

Весь проект лежит в архиве во вложении №5
Проект написан в VS 2008/
25
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды  
Изображения
  
Вложения
Тип файла: rar UserProgressBar.rar (184.8 Кб, 348 просмотров)
Russiablackbird
61 / 61 / 1
Регистрация: 23.01.2012
Сообщений: 254
11.05.2012, 20:45 #29
Для работы,добавляем в проект и импортируем штатную библиотеку shell32.dll Потом для упаковки пишем
vb.net
1
2
3
4
5
6
7
8
Sub Zip()
        Dim sh As New Shell32.Shell()
        Dim input As Shell32.Folder = sh.NameSpace("D:\Должностные инструкции")
        Dim ifs As IO.FileStream = IO.File.Create("d:\архив.zip")
        ifs.Close()
        Dim output As Shell32.Folder = sh.NameSpace("d:\архив.zip")
        output.CopyHere(input.Items, 4)
    End Sub
А для распаковки
vb.net
1
2
3
4
5
6
7
Sub UnZip()
        Dim sh As New Shell32.Shell()
        IO.Directory.CreateDirectory("d:\новая папка")
        Dim output As Shell32.Folder = sh.NameSpace("d:\новая папка")
        Dim input As Shell32.Folder = sh.NameSpace("d:\архив.zip")
        output.CopyHere(input.Items, 4)
    End Sub
21
Ciberst
507 / 420 / 19
Регистрация: 16.12.2010
Сообщений: 939
07.07.2012, 21:56 #30
Сбор мусора. (используется в основном при DDoS-атаках использование компонента WebBrowser и других разного рода вещей, когда вы наблюдаете рост памяти)
vb.net
1
GC.Collect
MSDN о GC.Collect
Цитата Сообщение от http://msdn.microsoft.com
Принудительно запускает немедленную сборку мусора для всех поколений.
Цитата Сообщение от http://msdn.microsoft.com
Используйте этот метод, чтобы попытаться высвободить всю недоступную память.
Сборке мусора подвергаются все объекты, вне зависимости от времени их нахождения в памяти. Однако объекты, на которые имеются ссылки в управляемом коде, не освобождаются. Используйте этот метод, чтобы принудительно предпринять попытку высвободить максимальный объем доступной памяти.
7
Юпатов Дмитрий
1612 / 1124 / 224
Регистрация: 23.12.2010
Сообщений: 1,495
12.07.2012, 14:50 #31
Писателям лаунчеров посвящается...

Пример программы для загрузки обновлений.
Внешний вид окна - см. вложение.
Полный код формы
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
Imports System.Net
Imports System.Security.Cryptography
Public Class Form1
#Region "Variables"
    Dim WithEvents DownloadClient As New WebClient
    Dim OriginString As New List(Of StringList) ' массив оригинальных строк с путями для закачки, хешами и относительными путями назначения
    Dim ResultString As New List(Of StringList) ' список отобранного для загрузки
    Dim CurrentNum As Integer = 0
    Dim RootFolder As String = "C:\Users\Yupatov\Desktop\папка1" ' локальная корневая папка
    Dim NetFolder As String = "http://mytestsource.narod.ru/folder1/" ' корневая папка на сервере, гле размещен файл с информацией. Файлы для загрузки могут быть в другом месте
    Dim IsFileLoading = False
    Dim Errorlog As String = String.Empty ' пустая строка. В процессе загрузки сюда пишется лог ошибок, если они есть. Потом ее можно прочитать (например, отобразить в MsgBox)
    Dim InfoFile As String = "UpdateInfo.upd" ' имя файла с информацией на сервере
    Dim seprow() As Char = {vbCr, vbLf} ' сепараторы для нарезки на строки
    Dim sepcell() As String = {"[cell]"} ' сепаратор нарезки отдельных строк
#End Region
    ''' <summary>
    ''' Структура для списка файлов: путь для скачивания с сервера; md5 файла, расположенного по этому пути; относительный путь к такому же файлу на локальном диске; md5 файла, расположенного по этому пути
    ''' </summary>
    ''' <remarks></remarks>
    Private Structure StringList
        Dim ServerPath As String
        Dim ServerHash_MD5 As String
        Dim LocalPath As String
        Dim LocalHash_MD5 As String
    End Structure
 
#Region "Downloader"
    Private Sub DownloadClient_DownloadFileCompleted(ByVal sender As Object, ByVal e As System.ComponentModel.AsyncCompletedEventArgs) Handles DownloadClient.DownloadFileCompleted
        If Not e.Error Is Nothing Then
            Errorlog = Errorlog & e.Error.ToString & vbCrLf & "----------" & vbCrLf
        End If
        CurrentNum = CurrentNum + 1
        If CurrentNum < Me.ResultString.Count Then
            Me.BeginDownload(Me.CurrentNum)
        Else
            IsFileLoading = False
            Me.CurrentNum = 0
            Me.Text = "Download complete"
            Me.OriginString.Clear()
            Me.ResultString.Clear()
            Me.lblLocalPath.Text = String.Empty
            Me.lblServerPath.Text = String.Empty
        End If
    End Sub
 
    Private Sub DownloadClient_DownloadProgressChanged(ByVal sender As Object, ByVal e As System.Net.DownloadProgressChangedEventArgs) Handles DownloadClient.DownloadProgressChanged
        If IsFileLoading = True Then
            Me.lblServerPath.Text = ResultString.Item(CurrentNum).ServerPath
            Me.lblLocalPath.Text = ResultString.Item(CurrentNum).LocalPath
        Else
            Me.Text = "Reading info..."
        End If
        Me.pbDownloadProgress.Value = Math.Min(e.BytesReceived, Me.pbDownloadProgress.Maximum)
        Me.pbDownloadProgress.Maximum = e.TotalBytesToReceive
        Me.Refresh()
    End Sub
 
    Private Sub DownloadClient_DownloadStringCompleted(ByVal sender As Object, ByVal e As System.Net.DownloadStringCompletedEventArgs) Handles DownloadClient.DownloadStringCompleted
        If Not e.Error Is Nothing Then
            Errorlog = Errorlog & e.Error.ToString & vbCrLf & "----------" & vbCrLf
            Exit Sub
        End If
        ' получаем массив строк
        For Each ostr As String In e.Result.Split(seprow, StringSplitOptions.RemoveEmptyEntries)
            Dim ss() As String = ostr.Split(sepcell, StringSplitOptions.RemoveEmptyEntries)
            Dim newSL As New StringList
            newSL.ServerPath = ss.GetValue(0)
            newSL.ServerHash_MD5 = ss.GetValue(1)
            newSL.LocalPath = Me.RootFolder & ss.GetValue(2)
            OriginString.Add(newSL)
        Next
        ' обрабатываем его, чтобы получить необходимое
        Add_LocalHashes_makeDirs()
        ' загружаем необходимые файлы
        If Me.ResultString.Count = 0 Then
            IsFileLoading = False
            Me.CurrentNum = 0
            Me.Text = "Nothing to download"
            Me.OriginString.Clear()
            Me.ResultString.Clear()
            Me.lblLocalPath.Text = String.Empty
            Me.lblServerPath.Text = String.Empty
        Else
            Me.BeginDownload(Me.CurrentNum)
        End If
    End Sub
 
    ''' <summary>
    ''' Процедура для старта загрузки файла
    ''' </summary>
    ''' <param name="CN">Порядковый номер файла в списке</param>
    ''' <remarks></remarks>
    Private Sub BeginDownload(ByVal CN As Integer)
        Me.IsFileLoading = True
        Me.Text = CurrentNum + 1 & "/" & Me.ResultString.Count
        Me.DownloadClient.DownloadFileAsync(New Uri(ResultString.Item(CN).ServerPath), ResultString.Item(CN).LocalPath)
    End Sub
#End Region
 
#Region "ComputingHash_MD5_makedir_fillresultstring"
    ''' <summary>
    ''' Функция вычисляет значение md5 для указанного файла, в случае его отсутствия присваивает -1
    ''' </summary>
    ''' <param name="filepath">Путь к файлу</param>
    ''' <returns>Хеш-сумма в виде строки</returns>
    ''' <remarks></remarks>
    Private Function GetHash(ByVal filepath As String) As String
        Try
            Dim checksum() As Byte
            Dim result As String = String.Empty
            Dim i As Integer
            Dim MD5Calc As New MD5CryptoServiceProvider
            Dim inStream As IO.Stream
            If IO.File.Exists(filepath) Then
                inStream = New IO.FileStream(filepath, IO.FileMode.Open, IO.FileAccess.Read)
            Else
                Return ("-1")
            End If
            checksum = MD5Calc.ComputeHash(inStream)
            inStream.Close()
            For i = 0 To checksum.Length - 1
                result &= String.Format("{0:X2}", checksum(i))
            Next
            Return result
        Catch ex As Exception
            Me.Errorlog = Me.Errorlog & ex.Message & vbCrLf & "----------" & vbCrLf
        End Try
        Return ("-1")
    End Function
 
    ''' <summary>
    ''' Процедура вычисляет md5 для локальных файлов, добавляет их значение в список OriginString и, при необходимости, создает недостающие каталоги для дальнейшего помещения туда файлов. Формирует список ResultString для загрузки
    ''' </summary>
    ''' <remarks></remarks>
    Private Sub Add_LocalHashes_makeDirs()
        For Each SL As StringList In Me.OriginString
            SL.LocalHash_MD5 = Me.GetHash(SL.LocalPath)
            If Not SL.ServerHash_MD5.Equals(SL.LocalHash_MD5) Then
                Me.ResultString.Add(SL)
                If IO.Directory.Exists(IO.Path.GetDirectoryName(SL.LocalPath)) = False Then
                    Try
                        IO.Directory.CreateDirectory(IO.Path.GetDirectoryName(SL.LocalPath))
                    Catch ex As Exception
                        Me.Errorlog = Me.Errorlog & ex.Message & vbCrLf & "----------" & vbCrLf
                    End Try
                End If
            End If
        Next
    End Sub
 
#End Region
 
    Private Sub btnDownload_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnDownload.Click
        DownloadClient.DownloadStringAsync(New Uri(NetFolder & InfoFile))
    End Sub
 
End Class

Что необходимо на сервере:
1) файл UpdateInfo.upd, который расположен по пути, указанному в переменной NetFolder
2) файлы обновлений, которые предстоит скачать. Расположение - где угодно, хоть на другом сервере (пути к ним прописываются в файле из п.1)

Структура файла UpdateInfo.upd - текстовый, с разделителями.
Строки разделены символами vbCr + vbLf
Сами строки имеют такую структуру:
Полный путь к файлу для скачивания[cell]MD5 файла в виде строки[cell]относительный путь для сохранения на локальной машине (относительно значения переменной RootFolderRoot)
Пример содержимого
http://mytestsource.narod.ru/folder1/File1.dll[cell]E047210B4CE2BBF0F6A9819031C5874A[cell]\File1.dll
http://mytestsource.narod.ru/folder1/File1.exe[cell]CAB0FFC1844E892CB44BC98359520CF0[cell]\Folder1\File1.exe
http://mytestsource.narod.ru/folder1/File2.bin[cell]31A69F32502DE8B29ED98BFA19DE1332[cell]\Folder1\File2.bin
http://mytestsource.narod.ru/folder1/File2.dll[cell]A74A9A50110E5F5B3AD0B2DCBDB1E6E8[cell]\Folder2\File2.dll

Что тут и как работает:
1) нажатием на кнопку запускаем процесс скачивания.
2) загружается содержимое файла UpdateInfo.upd
3) формируется список OriginStrings путем порезки полученных данных на фрагменты
4) имея корневую локальную папку и получив из файла UpdateInfo.upd относительные пути к файлам, вычисляются хеши локально расположенных файлов. Проверяется совпадение полученных хешей и вычисленных. Если совпали - файл качать не надо. Если не совпали:
- файл (точнее, елемент списка) добавляется в список ResultStrings. Одновременно создаются необходимые пустые каталоги (смотрим на полученный относительный путь)
- теперь производится собственно закачка каждого файла из списка ResultStrings и его сохранение в нужном месте (корневой путь у нас задан, относительные мы получили)
5) В процессе закачки на форме отображается процесс закачки каждого файла с отображением также серверного пути и локального. Т.е. откуда и куда качаем. В заголовке формы работает счетчик, показывающий порядковый номер файла из списка и длину списка.


Поскольку файл UpdateInfo.upd имеет достаточно специфические данные, написана также небольшая утилитка, которая может его формировать. Это утилитка для собственника программы, который будет заботиться о периодическом обновлении своего ПО.
Тут все просто:
1) Имеем папку с внутренней иерархией, повторяющей установленную программу, которую следует обновлять. В идеале - пересобрал прогу, установил у себя и потом используешь папку с установленной прогой.
В начале указываем путь к этой корневой папке.
Далее нажимаем "Подготовить данные". При этом заполнятся столбцы с локальным относительным путем и хешем файла. Желательно строку со значением MD5 получать именно отсюда, т.к. она никак не сегментирована, а просто непрерывный ряд символов. Другие программы могут выдавать значение в несколько отличающемся формате. Хотя массив байтов с хешем будет эквивалентен.
После этого остается (уже ручками) в столбец пути на сервере вписать путь к каждому файлу (путь на сервере, абсолютный. Вот почему ранее я написал, что файлы могут лежать где угодно и как угодно)
Код формы
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Imports System.Security.Cryptography
Public Class Form1
 
    Private Sub btnBrowse_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnBrowse.Click
        If Me.dgvResults.RowCount > 0 Then
            If MsgBox("Вы действительно хотите очистить предыдущие результаты?", MsgBoxStyle.YesNo Or MsgBoxStyle.Question) = MsgBoxResult.Yes Then
                Me.txtPath.Text = String.Empty
                Me.dgvResults.Rows.Clear()
            End If
        End If
        Dim FBD As New FolderBrowserDialog
        With FBD
            .ShowNewFolderButton = False
        End With
        If FBD.ShowDialog = Windows.Forms.DialogResult.OK Then
            Me.txtPath.Text = FBD.SelectedPath
            Me.btnFillTable.Enabled = True
            Me.btnSavetofile.Enabled = True
        End If
    End Sub
 
    Private Sub Form1_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        Me.btnFillTable.Enabled = False
        Me.btnSavetofile.Enabled = False
    End Sub
 
    Private Sub btnFillTable_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnFillTable.Click
        For Each pth As String In My.Computer.FileSystem.GetFiles(Me.txtPath.Text, FileIO.SearchOption.SearchAllSubDirectories)
            Me.dgvResults.Rows.Add(1)
            Me.dgvResults.Item(2, Me.dgvResults.Rows.Count - 1).Value = pth.Replace(Me.txtPath.Text, String.Empty)
            Me.dgvResults.Item(1, Me.dgvResults.Rows.Count - 1).Value = Me.GetHash(pth)
        Next
    End Sub
 
    ''' <summary>
    ''' Функция вычисляет значение md5 для указанного файла, в случае его отсутствия присваивает -1
    ''' </summary>
    ''' <param name="filepath">Путь к файлу</param>
    ''' <returns>Хеш-сумма в виде строки</returns>
    ''' <remarks></remarks>
    Private Function GetHash(ByVal filepath As String) As String
        Try
            Dim checksum() As Byte
            Dim result As String = String.Empty
            Dim i As Integer
            Dim MD5Calc As New MD5CryptoServiceProvider
            Dim inStream As IO.Stream
            If IO.File.Exists(filepath) Then
                inStream = New IO.FileStream(filepath, IO.FileMode.Open, IO.FileAccess.Read)
            Else
                Return ("-1")
            End If
            checksum = MD5Calc.ComputeHash(inStream)
            For i = 0 To checksum.Length - 1
                result &= String.Format("{0:X2}", checksum(i))
            Next
            Return result
        Catch ex As Exception
            MsgBox(ex.ToString)
        End Try
    End Function
 
    Private Sub btnSavetofile_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnSavetofile.Click
        If Me.dgvResults.RowCount = 0 Then Exit Sub
        Dim result As String = String.Empty
        For i As Integer = 0 To Me.dgvResults.Rows.Count - 1
            result = result & CStr(Me.dgvResults.Item(0, i).Value) & "[cell]" & CStr(Me.dgvResults.Item(1, i).Value) & "[cell]" & CStr(Me.dgvResults.Item(2, i).Value) & vbCr & vbLf
        Next
        Dim SFD As New SaveFileDialog
        With SFD
            .InitialDirectory = Me.txtPath.Text
            .DefaultExt = "upd"
            .Filter = "Файлы .udp|*.upd"
            .FileName = "Info.upd"
            .ShowHelp = False
            .AddExtension = True
        End With
        If SFD.ShowDialog = Windows.Forms.DialogResult.OK Then
            Try
                Dim SW As New IO.StreamWriter(SFD.FileName)
                SW.Write(result)
                SW.Close()
            Catch ex As Exception
                MsgBox(ex.ToString)
            End Try
        End If
    End Sub
End Class

Ну и, конечно:
1) пути, указанные в кодах - живые. Я ж тоже тестил все это.
2) как всегда - во вложениях архивы с проектами
3) естественно, код не идеален, могут возникать необработанные исключения - хотя тестировал в разных ситуациях, но недолго.
27
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды   Visual Basic .NET FAQ. Готовые решения, полезные коды  
Вложения
Тип файла: rar WindowsApplication1.rar (108.2 Кб, 322 просмотров)
Тип файла: rar WindowsApplication2.rar (146.2 Кб, 303 просмотров)
Ciberst
507 / 420 / 19
Регистрация: 16.12.2010
Сообщений: 939
14.07.2012, 17:27 #32
следующий код позволит создать область выделения(как в знаменитых фоторедакторах)
Visual Basic .NET FAQ. Готовые решения, полезные коды
код
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
Public Class Form1
 
    Dim isDrag As Boolean = False
    Dim theRectangle As New Rectangle(New Point(0, 0), New Size(0, 0))
    Dim startPoint As Point
 
    Private Sub Form1_MouseDown(ByVal sender As Object, ByVal e As  _
        System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseDown
 
        If (e.Button = MouseButtons.Left) Then
            isDrag = True
        End If
 
        Dim control As Control = CType(sender, Control)
 
       
        startPoint = control.PointToScreen(New Point(e.X, e.Y))
    End Sub
 
    Private Sub Form1_MouseMove(ByVal sender As Object, ByVal e As  _
    System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseMove
 
       
        If (isDrag) Then
 
         
            ControlPaint.DrawReversibleFrame(theRectangle, Me.BackColor, _
                FrameStyle.Dashed)
 
           
            Dim endPoint As Point = CType(sender, Control).PointToScreen(New Point(e.X, e.Y))
            Dim width As Integer = endPoint.X - startPoint.X
            Dim height As Integer = endPoint.Y - startPoint.Y
            theRectangle = New Rectangle(startPoint.X, startPoint.Y, _
                width, height)
 
 
            ControlPaint.DrawReversibleFrame(theRectangle, Me.BackColor, _
                 FrameStyle.Dashed)
        End If
    End Sub
 
    Private Sub Form1_MouseUp(ByVal sender As Object, ByVal e As  _
    System.Windows.Forms.MouseEventArgs) Handles MyBase.MouseUp
 
 
        isDrag = False
 
        
        ControlPaint.DrawReversibleFrame(theRectangle, Me.BackColor, _
            FrameStyle.Dashed)
 
        Dim i As Integer
        Dim controlRectangle As Rectangle
        For i = 0 To Controls.Count - 1
            controlRectangle = Controls(i).RectangleToScreen _
                (Controls(i).ClientRectangle)
            If controlRectangle.IntersectsWith(theRectangle) Then
                Controls(i).BackColor = Color.BurlyWood
            End If
        Next
 
        theRectangle = New Rectangle(0, 0, 0, 0)
    End Sub
 
End Class


Получить имя переменной
vb.net
1
2
3
4
5
6
7
8
9
    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
        Dim abc As String = "123"
        Dim a = New With {abc}
        MsgBox(GetName(a) & " = " & abc)
 
    End Sub
    Public Function GetName(ByVal obj As Object) As String
        Return obj.[GetType]().GetProperties()(0).Name
    End Function
8
вадим2
91 / 91 / 3
Регистрация: 01.12.2011
Сообщений: 94
06.08.2012, 11:43 #33
Загрузка файла на FTP сервер с прогрессом
Создаём новый проект, на форму кидаем Button1, Label1, ProgressBar1.
Весь код формы заменяем на:
vb.net
1
2
3
4
5
6
7
8
9
Imports System.IO
Imports System.Net
Imports System.ComponentModel
Public Class Form1
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        Dim downloader As New filesuploader("Имя пользователя", "мой сайт.ru/", "пароль", Label1, ProgressBar1)
        downloader.Загрузить_файл("C:\file.exe")
    End Sub
End Class
Так же добавляем класс filesuploader, со следующим содержанием:

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Public Class filesuploader
    Dim сервер As String
    Dim логин As String
    Dim пароль As String
    Dim label2 As Object
    Dim progressbar1 As Object
    ''' <summary>
    ''' Данные для работы класса
    ''' </summary>
    ''' <param name="логинinf">Логин для входа на FTP сервер.</param>
    ''' <param name="серверinf">Адрес сервера, например: mysite.ru/. Для сайта на яндекс.народ: mysite.ftp.narod.ru/</param>
    ''' <param name="парольinf">Пароль для входа на FTP сервер</param>
    ''' <param name="надпись_информацииinf">Label, в которой отображается информация(скорость, оставшееся время).</param>
    ''' <param name="полоса_загрузкиinf">Progressbar, в котором отображается прогресс загрузки.</param>
    ''' <remarks></remarks>
    Public Sub New(ByVal логинinf As String, ByVal серверinf As String, ByVal парольinf As String, ByVal надпись_информацииinf As Object, ByVal полоса_загрузкиinf As Object)
        логин = логинinf
        сервер = серверinf
        пароль = парольinf
        label2 = надпись_информацииinf
        progressbar1 = полоса_загрузкиinf
        worker.WorkerReportsProgress = True
    End Sub
    Dim WithEvents worker As New BackgroundWorker
    ''' <summary>
    ''' Загружает файл на FTP сервер с отображением прогресса и информации.
    ''' </summary>
    ''' <param name="файл">Укажите путь к загружаемому файлу.</param>
    ''' <remarks></remarks>
    Sub Загрузить_файл(ByVal файл As String)
        progressbar1.Value = 0
        Dim fileinf As New FileInfo(файл)
        Try
            progressbar1.Maximum = fileinf.Length / buffLength + 1
        Catch ex As Exception
            progressbar1.Maximum = 100
        End Try
        worker.RunWorkerAsync(New Object() {файл})
    End Sub
    Dim buffLength As Integer = 2048
    Dim str As String
    Private Sub worker_DoWork(ByVal sender As Object, ByVal e As DoWorkEventArgs) Handles worker.DoWork
        Try
            Dim fileInf As New FileInfo(e.Argument(0).ToString)
            Dim reqFTP As FtpWebRequest
            reqFTP = DirectCast(FtpWebRequest.Create(New Uri("ftp://" + сервер + "/" & fileInf.Name)), FtpWebRequest)
            reqFTP.Credentials = New NetworkCredential(логин, пароль)
            reqFTP.KeepAlive = False
            reqFTP.Method = WebRequestMethods.Ftp.UploadFile
            Application.DoEvents()
            reqFTP.UseBinary = True
            reqFTP.ContentLength = fileInf.Length
            Dim buff As Byte() = New Byte(buffLength) {}
            Dim contentLen As Integer
            Dim fs As FileStream = fileInf.OpenRead()
            Dim strm As Stream = reqFTP.GetRequestStream()
            contentLen = fs.Read(buff, 0, buffLength)
            Dim str1 As Integer = 0
            Dim all As Integer = 0
            Dim tmr As String
            Dim i12 As Integer
            While contentLen <> 0
                tmr = Split(My.Computer.Clock.LocalTime, ":")(2)
                strm.Write(buff, 0, contentLen)
                all = all + buffLength
                contentLen = fs.Read(buff, 0, buffLength)
                str1 = str1 + buffLength
                i12 = i12 + 1
                If tmr = Split(My.Computer.Clock.LocalTime, ":")(2) Then
                Else
                    Dim time As String
                    Dim int As Integer = (fileInf.Length - all) / str1
                    If int > 60 Then
                        time = "Осталось " & Replace((int / 60).ToString, ",", " мин, ") & " сек."
                        If Len(Split(int / 60, ",")(1)) > 3 Then
                            time = "Осталось " & Split(int / 60, ",")(0) & " мин."
                        End If
                    Else
                        time = "Осталось " & int.ToString & " сек."
                    End If
                    str = "Скорость: " & str1.ToString / 1024 & " КБ/С. " & time
                    str1 = 0
                End If
                worker.ReportProgress(i12)
            End While
            strm.Close()
            fs.Close()
            str = Nothing
            worker.ReportProgress(progressbar1.Maximum())
            ' Return "Http://www." & Replace(сервер, "ftp.", Nothing) & "/" & fileInf.Name
        Catch
            MessageBox.Show(Err.Description, "", MessageBoxButtons.OK, MessageBoxIcon.Error)
            ' Return Nothing
        End Try
    End Sub
    Private Sub Worker_ProgressChanged(ByVal sender As Object, ByVal e As ProgressChangedEventArgs) Handles worker.ProgressChanged
        progressbar1.Value = e.ProgressPercentage
        label2.Text = str
    End Sub
    Private Sub Worker_RunWorkerCompleted(ByVal sender As Object, ByVal e As RunWorkerCompletedEventArgs) Handles worker.RunWorkerCompleted
        MessageBox.Show("Файл успешно загружен!", "", MessageBoxButtons.OK, MessageBoxIcon.Asterisk)
    End Sub
End Class
7
_Лёша_
384 / 374 / 21
Регистрация: 08.02.2011
Сообщений: 1,078
22.11.2012, 16:53 #34
Telnet клиент на Vb.net
3
Вложения
Тип файла: zip telnet client.zip (26.8 Кб, 213 просмотров)
_Лёша_
384 / 374 / 21
Регистрация: 08.02.2011
Сообщений: 1,078
22.11.2012, 16:59 #35
Пример передачи файлов любого размера по tcp.
2 консольных приложения:
клиент:
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
Imports System.Collections
Imports System.Collections.Generic
Imports System.Data
Imports System.Diagnostics
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports System.IO
 
NotInheritable Class Program
    Private Sub New()
    End Sub
 
    Public Shared Sub Main()
        Do
            Dim Filename As String = Nothing
            Console.WriteLine("Перетащите файл на консоль для отправки и нажмите Enter")
            Filename = Console.ReadLine().Replace("""", "")
            Dim client As New TcpClient("127.0.0.1", 20000)
            Using inputStream As FileStream = File.OpenRead(Filename)
                Using outputStream As NetworkStream = client.GetStream()
                    Using writer As New BinaryWriter(outputStream)
                        Dim lenght As Long = inputStream.Length
                        Dim totalBytes As Long = 0
                        Dim readBytes As Integer = 0
                        Dim buffer As Byte() = New Byte(2047) {}
                        writer.Write(Path.GetFileName(Filename))
                        writer.Write(lenght)
                        Do
                            readBytes = inputStream.Read(buffer, 0, buffer.Length)
                            outputStream.Write(buffer, 0, readBytes)
                            totalBytes += readBytes
                        Loop While client.Connected AndAlso totalBytes < lenght
                    End Using
                End Using
            End Using
            client.Close()
        Loop While True
    End Sub
End Class

Сервер:
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Imports System.Collections
Imports System.Collections.Generic
Imports System.Data
Imports System.Diagnostics
Imports System.Net
Imports System.Net.Sockets
Imports System.Text
Imports System.IO
 
NotInheritable Class Program
    Private Sub New()
    End Sub
 
 
    Public Shared Sub Main()
 
        Dim folder As String = "recived"
        Dim listener As New TcpListener(IPAddress.Any, 20000)
        listener.Start()
        While True
            Dim client As TcpClient = listener.AcceptTcpClient()
            Using inputStream As NetworkStream = client.GetStream()
                Using reader As New BinaryReader(inputStream)
                    Dim filename As String = reader.ReadString()
                    Dim lenght As Long = reader.ReadInt64()
                    Using outputStream As FileStream = File.Open(Path.Combine(folder, filename), FileMode.Create)
                        Dim totalBytes As Long = 0
                        Dim readBytes As Integer = 0
                        Dim buffer As Byte() = New Byte(2047) {}
 
                        Do
                            readBytes = inputStream.Read(buffer, 0, buffer.Length)
                            outputStream.Write(buffer, 0, readBytes)
                            totalBytes += readBytes
                        Loop While client.Connected AndAlso totalBytes < lenght
                        Console.WriteLine("Принят файл " & filename & " Размер " & totalBytes)
                    End Using
 
                End Using
            End Using
 
            client.Close()
        End While
 
    End Sub
End Class
8
АББА
133 / 60 / 24
Регистрация: 08.11.2012
Сообщений: 250
29.01.2013, 19:04 #36
Имя пользователя:
vb.net
1
Label6.Text = My.User.Name

Операционная система:
vb.net
1
2
3
With My.Computer.Info
Msgbox(.OSFullName & " " & .OSVersion)
End With

Видеокарта(VGA):
vb.net
1
2
3
4
Dim a As ManagementObjectSearcher = New ManagementObjectSearcher("SELECT * FROM Win32_VideoController")
For Each видеокарта As ManagementObject In a.Get()
Msgbox(видеокарта("Name"))
Next

Режим экрана:
vb.net
1
2
3
4
5
6
With My.Computer.Screen
            Dim x$ = .Bounds.Size.Width
            Dim y$ = .Bounds.Size.Height
            Dim bit% = .BitsPerPixel
          msgbox( x & " x " & y & " (" & bit & " бит" & ")")
 End With


Процессор:
vb.net
1
2
3
4
5
6
7
8
Dim процессор = My.Computer.Registry.LocalMachine.OpenSubKey _
                        ("HARDWARE\\DESCRIPTION\\SYSTEM\\CentralProcessor\\0", False)
        With процессор
            Label1.Text = .GetValue("ProcessorNameString")
            ListBox1.Items.Add("Частота (MHz): " & .GetValue("~MHz"))
            ListBox1.Items.Add("Идентификация: " & .GetValue("Identifier"))
            ListBox1.Items.Add("Ид. продавца: " & .GetValue("VendorIdentifier"))
        End With

Получение информации о дисках:
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
 Dim имя$ = ""
        Dim s$ = "   "
        Const d% = 1073741824
        With My.Computer.FileSystem
            For i = 0 To .Drives.Count - 1
                имя = .Drives.Item(i).Name
 
                'Добавляем в лист имя диска
                ListBox2.Items.Add(.GetDriveInfo(имя).VolumeLabel & "_" & имя)
 
                'Проверка общего объёма диска
                Dim obem = Val(.GetDriveInfo(имя).TotalSize)
 
                ListBox2.Items.Add(s & "Общий объем: " & obem & " Байт | " & _
                                   Format(Val(obem) / d, "0.00") & " Гб")
                'Проверка свободного объёма диска
                Dim svob = Val(.GetDriveInfo(имя).TotalFreeSpace)
 
                ListBox2.Items.Add(s & "Свободно: " & svob & " Байт | " & _
                                   Format(Val(svob) / d, "0.00") & " Гб")
 
                'Получение информации об файловой системе
                ListBox2.Items.Add(s & "Файловая система: " & _
                      .GetDriveInfo(имя).DriveFormat)
 
                'Тип диска
                ListBox2.Items.Add(s & "Тип диска: " & _
                      .GetDriveInfo(имя).DriveType)
            Next
        End With
8
Pe4eNEG
111 / 111 / 10
Регистрация: 12.06.2010
Сообщений: 479
Записей в блоге: 2
02.02.2013, 11:54 #37
Для начала добавляем в проект новый класс, называем его Shortcut и записываем следующий код:
Код Shortcut.vb
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Imports System.Runtime.InteropServices
Imports System.Runtime.InteropServices.ComTypes
Imports System.Text
 
Public Class Shortcut
    ' egl1044
    Private Const CLSID_ShellLink As String = "00021401-0000-0000-C000-000000000046"
    Private Const CLSID_FolderShortcut As String = "0AFACED1-E828-11D1-9187-B532F1E9575D"
    Private dataBuffer As New StringBuilder(260)
    Public Enum LinkType As Integer
        File
        Folder
    End Enum
    Public Enum WindowStyle As Integer
        Normal = 1
        Maximized = 3
        ShowMinNoActive = 7
    End Enum
    Private psl As IShellLinkW = Nothing
    Private ppf As IPersistFile = Nothing
    Public Sub New(ByVal shortcutlinkType As LinkType)
        ' Get a pointer to the IShellLink interface.
        Select Case shortcutlinkType
            Case LinkType.File
                psl = DirectCast(Activator.CreateInstance(Type.GetTypeFromCLSID(New Guid(CLSID_ShellLink)), True), IShellLinkW)
            Case LinkType.Folder
                psl = DirectCast(Activator.CreateInstance(Type.GetTypeFromCLSID(New Guid(CLSID_FolderShortcut)), True), IShellLinkW)
        End Select
    End Sub
    Protected Overrides Sub Finalize()
        Me.Release()
        MyBase.Finalize()
    End Sub
    Public Sub Save(ByVal pszFileName As String)
        ' Get a pointer to the IPersistFile interface.
        ppf = DirectCast(psl, IPersistFile)
        ppf.Save(pszFileName, True)
    End Sub
    Public Sub Load(ByVal pszFileName As String)
        ' Get a pointer to the IPersistFile interface.
        ppf = DirectCast(psl, IPersistFile)
        ppf.Load(pszFileName, 0)
        psl.Resolve(IntPtr.Zero, 0)
    End Sub
    Public Function SetPath(ByVal pszFile As String) As Integer
        Return psl.SetPath(pszFile)
    End Function
    Public Function SetDescription(ByVal pszName As String) As Integer
        Return psl.SetDescription(pszName)
    End Function
    Public Function SetWorkingDirectory(ByVal pszDir As String) As Integer
        Return psl.SetWorkingDirectory(pszDir)
    End Function
    Public Function SetIconLocation(ByVal pszIconPath As String, ByVal iconIndex As Integer) As Integer
        Return psl.SetIconLocation(pszIconPath, iconIndex)
    End Function
    Public Function SetArguments(ByVal pszArgs As String) As Integer
        Return psl.SetArguments(pszArgs)
    End Function
    Public Function SetShowCmd(ByVal showCmd As WindowStyle) As Integer
        Return psl.SetShowCmd(showCmd)
    End Function
    Public Function SetHotKey(ByVal wHotKey As Short) As Integer
        Return psl.SetHotkey(wHotKey)
    End Function
    Public Function GetPath() As String
        psl.GetPath(dataBuffer, dataBuffer.Capacity, IntPtr.Zero, 0)
        Return dataBuffer.ToString
    End Function
    Public Function GetArguments() As String
        psl.GetArguments(dataBuffer, dataBuffer.Capacity)
        Return dataBuffer.ToString
    End Function
    Public Function GetDescription() As String
        psl.GetDescription(dataBuffer, dataBuffer.Capacity)
        Return dataBuffer.ToString
    End Function
    Public Function GetIconLocation() As ShortcutIconInfo
        Dim iconIndex As Integer
        psl.GetIconLocation(dataBuffer, dataBuffer.Capacity, iconIndex)
        Return New ShortcutIconInfo(dataBuffer.ToString, iconIndex)
    End Function
    Public Function GetWorkingDirectory() As String
        psl.GetWorkingDirectory(dataBuffer, dataBuffer.Capacity)
        Return dataBuffer.ToString
    End Function
    Public Function GetShowCommand() As Integer
        Dim pShowCmd As Integer
        psl.GetShowCmd(pShowCmd)
        Return pShowCmd
    End Function
    Public Function GetHotkey() As Short
        Dim pHotKey As Short
        psl.GetHotkey(pHotKey)
        Return pHotKey
    End Function
    Public Sub Release()
        If ppf IsNot Nothing Then
            Marshal.FinalReleaseComObject(ppf)
            ppf = Nothing
        End If
        If psl IsNot Nothing Then
            Marshal.FinalReleaseComObject(psl)
            psl = Nothing
        End If
    End Sub
 
    Public Class ShortcutIconInfo
        Private _iconLocation As String = String.Empty
        Private _iconIndex As Integer = 0
        Protected Friend Sub New(ByVal iconLocation As String, ByVal iconIndex As Integer)
            Me._iconLocation = iconLocation
            Me._iconIndex = iconIndex
        End Sub
        Public ReadOnly Property Location As String
            Get
                Return _iconLocation
            End Get
        End Property
        Public ReadOnly Property Index As Integer
            Get
                Return _iconIndex
            End Get
        End Property
    End Class
 
 
End Class
 
''' <summary>
''' IShellLinkW Interface
''' [url]http://msdn.microsoft.com/en-us/library/bb774950(VS.85).aspx[/url]
''' </summary>
''' <remarks>This interface cannot be used to create a link to a URL.</remarks>
<ComImport(), InterfaceType(ComInterfaceType.InterfaceIsIUnknown), _
Guid("000214F9-0000-0000-C000-000000000046")> _
Public Interface IShellLinkW
    <PreserveSig()> _
    Function GetPath(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As StringBuilder, ByVal cchMaxPath As Integer, ByVal pfd As IntPtr, ByVal fFlags As Integer) As Integer
    <PreserveSig()> _
    Function GetIDList(ByRef ppidl As IntPtr) As Integer
    <PreserveSig()> _
    Function SetIDList(ByVal pidl As IntPtr) As Integer
    <PreserveSig()> _
    Function GetDescription(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As StringBuilder, ByVal cchMaxName As Integer) As Integer
    <PreserveSig()> _
    Function SetDescription(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszName As String) As Integer
    <PreserveSig()> _
    Function GetWorkingDirectory(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As StringBuilder, ByVal cchMaxPath As Integer) As Integer
    <PreserveSig()> _
    Function SetWorkingDirectory(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszDir As String) As Integer
    <PreserveSig()> _
    Function GetArguments(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As StringBuilder, ByVal cchMaxPath As Integer) As Integer
    <PreserveSig()> _
    Function SetArguments(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszArgs As String) As Integer
    <PreserveSig()> _
    Function GetHotkey(ByRef pwHotkey As Short) As Integer
    <PreserveSig()> _
    Function SetHotkey(ByVal wHotkey As Short) As Integer
    <PreserveSig()> _
    Function GetShowCmd(ByRef piShowCmd As Integer) As Integer
    <PreserveSig()> _
    Function SetShowCmd(ByVal iShowCmd As Integer) As Integer
    <PreserveSig()> _
    Function GetIconLocation(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As StringBuilder, ByVal cchIconPath As Integer, ByRef piIcon As Integer) As Integer
    <PreserveSig()> _
    Function SetIconLocation(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszIconPath As String, ByVal iIcon As Integer) As Integer
    <PreserveSig()> _
    Function SetRelativePath(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszPathRel As String, ByVal dwReserved As Integer) As Integer
    <PreserveSig()> _
    Function Resolve(ByVal hWnd As IntPtr, ByVal fFlags As Integer) As Integer
    <PreserveSig()> _
    Function SetPath(<MarshalAs(UnmanagedType.LPWStr)> ByVal pszFile As String) As Integer
End Interface


А теперь как это использовать:
Ярлык на файл
vb.net
1
2
3
Dim sc As New Shortcut(Shortcut.LinkType.File)
sc.SetPath("диск:\имя программы.exe")
sc.Save("диск:\имя ярлыка.lnk")


Ярлык на папку
vb.net
1
2
3
Dim sc As New Shortcut(Shortcut.LinkType.Folder)
sc.SetPath("диск:\папка")
sc.Save("диск:\имя ярлыка для папки без расширения lnk")


Ярлык с описанием
vb.net
1
2
3
4
Dim sc As New Shortcut(Shortcut.LinkType.File)
sc.SetPath("диск:\программа.exe")
sc.SetDescription("Описание ярлыка")
sc.Save("диск:\имя ярлыка.lnk")


Ярлык на файл с аргументами командной строки и описанием
vb.net
1
2
3
4
5
Dim sc As New Shortcut(Shortcut.LinkType.File)
sc.SetPath("диск:\путь\программа.exe")
sc.SetDescription("Ярлык для программа")
sc.SetArguments("аргументы командной строки")
sc.Save("диск:\путь\ярлык для программа.lnk")


Ярлык на файл с изменением его иконки
vb.net
1
2
3
4
5
6
Dim sc As New Shortcut(Shortcut.LinkType.File)
sc.SetPath("путь\программа.exe")
sc.SetDescription("ярлык для программа")
sc.SetArguments("аргументы командной строки")
sc.SetIconLocation("путь до объекта с иконками (dll или exe)", номер иконки в файле)
sc.Save("путь\ярлык для программа.lnk")


Получение информации о ярлыке
vb.net
1
2
3
4
5
6
7
8
Dim sc As New Shortcut(Shortcut.LinkType.File)
sc.Load("g:\notepad.lnk")
Debug.Print(sc.GetPath())
Debug.Print(sc.GetDescription)
Debug.Print(sc.GetArguments)
Dim sci As Shortcut.ShortcutIconInfo = sc.GetIconLocation
Debug.Print(sci.Location)
Debug.Print(sci.Index)


У кода есть небольшой минус: ярлык не создается там где требуются права администратора, у меня программа отказалась создать ярлык на разделе с Windows 8. Если у Вас отключен UAC то скорее всего таких проблем не будет.
7
Павлик Морозов
117 / 119 / 38
Регистрация: 26.10.2012
Сообщений: 402
Завершенные тесты: 1
09.02.2013, 18:29 #38
Шифрование пароля(каких-либо личных данных) алгоритмом TripleDES.

В проекте создаем класс:

Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Imports System.Security.Cryptography
Imports System.Text
Public NotInheritable Class MainEnCryptingClass
    Private TripleDes As New TripleDESCryptoServiceProvider
    Sub New(ByVal key As String)
        ' Инициализация основного процесса шифрования.
        TripleDes.Key = TruncateHash(key, TripleDes.KeySize \ 8)
        TripleDes.IV = TruncateHash("", TripleDes.BlockSize \ 8)
    End Sub
 
    Private Function TruncateHash(ByVal key As String, ByVal length As Integer) As Byte()
 
        Dim sha1 As New SHA1CryptoServiceProvider
 
        ' Хэшируется ключ
        Dim keyBytes() As Byte = Encoding.Unicode.GetBytes(key)
        Dim hash() As Byte = sha1.ComputeHash(keyBytes)
 
        ReDim Preserve hash(length - 1)
        Return hash
    End Function
 
    Public Function EncryptData(ByVal plaintext As String) As String
 
        ' Переводим ключ в байтовый массив
        Dim plaintextBytes() As Byte = Encoding.Unicode.GetBytes(plaintext)
 
        ' Создается MemoryStream.
        Dim ms As New System.IO.MemoryStream
        ' Создание кодировщика
        Dim encStream As New CryptoStream(ms, TripleDes.CreateEncryptor(), CryptoStreamMode.Write)
 
        ' Использование шифрованного потока для записи массива.
        encStream.Write(plaintextBytes, 0, plaintextBytes.Length)
        encStream.FlushFinalBlock()
 
        ' Перевод ключа в тестовый формат.
        Return Convert.ToBase64String(ms.ToArray)
    End Function
 
    Public Function DecryptData(ByVal encryptedtext As String) As String
 
        ' Переводим ключ в байтовый массив
        Dim encryptedBytes() As Byte = Convert.FromBase64String(encryptedtext)
 
        '  Создается MemoryStream.
        Dim ms As New System.IO.MemoryStream
        ' Создание кодировщика
        Dim decStream As New CryptoStream(ms, TripleDes.CreateDecryptor(), CryptoStreamMode.Write)
 
        ' Использование шифрованного потока для записи массива.
        decStream.Write(encryptedBytes, 0, encryptedBytes.Length)
        decStream.FlushFinalBlock()
 
        ' Перевод ключа в тестовый формат.
        Return Encoding.Unicode.GetString(ms.ToArray)
    End Function
End Class


Далее в классе формы запускаем события шифрования/дешифрования данных:

Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
'Шифруем пароль
    Private Function PasswordEncrypting()
        Dim wrapper As New MainEnCryptingClass("Ключ") 'Ключ для шифрования/расшифровки. Можно зашить 
'жестко в код, можно и передавать в ходе работы приложения
        CryptPass = wrapper.EncryptData(PasswordTxt.Text) 'PasswordTxt.Text - Информация, подлежащая шифрованию
        Return CryptPass
    End Function
 
'Значение полученной переменной CryptPass можно писать куда угодно. 
'Будь то xml-файл с настройками ConnectionString или 
'пароль для авторизации пользователя, хранящийся в БД
    
'Расшифровываем пароль
'Из ресурса получили зашифрованную информацию в переменной CryptData.
    Private Function PasswordDecrypt()
        Dim wrapper As New MainEnCryptingClass("Ключ") 'Должен быть идентичен ключу шифрования
        DecryptPass = wrapper.DecryptData(CryptData)
        Return DecryptPass 'В этой переменной расшифрованная информация
    End Function
13
Маршинин
50 / 50 / 1
Регистрация: 05.12.2012
Сообщений: 167
Записей в блоге: 1
20.02.2013, 05:25 #39
Командная строка на форме Windows!
Кликните здесь для просмотра всего текста

vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
Imports System.Runtime.InteropServices
Imports System.Text
Public Class Form1
    Private WithEvents MyProcess As Process
    Private Delegate Sub AppendOutputTextDelegate(ByVal text As String)
    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        MyProcess.StandardInput.WriteLine("EXIT") 'Отпровляем запрос закрытия
        MyProcess.StandardInput.Flush()
        MyProcess.Close()
    End Sub
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.AcceptButton = Button1
        MyProcess = New Process
        With MyProcess.StartInfo
            .FileName = "C:\Windows\system32\cmd.EXE"
            .UseShellExecute = False
            .CreateNoWindow = True
            .RedirectStandardInput = True
            .RedirectStandardOutput = True
            .RedirectStandardError = True
        End With
        MyProcess.Start()
        MyProcess.BeginErrorReadLine()
        MyProcess.BeginOutputReadLine()
        AppendOutputText("Процесс запусчен: " & MyProcess.StartTime.ToString)
    End Sub
 
    Private Sub MyProcess_OutputDataReceived(sender As Object, e As DataReceivedEventArgs) Handles MyProcess.OutputDataReceived 'Оброботка обычных ответов (Статитческих)
        AppendOutputText(vbCrLf & Encoding.Default.GetString(Encoding.Convert(Encoding.GetEncoding(866), Encoding.Default, Encoding.Default.GetBytes(e.Data))))
    End Sub
 
    Private Sub MyProcess_ErrorDataReceived(ByVal sender As Object, ByVal e As System.Diagnostics.DataReceivedEventArgs) Handles MyProcess.ErrorDataReceived 'Оброботка ошибок и потоковых данных(Пример:загрузка какой либо игры через консоль)
        AppendOutputText(vbCrLf & "Error: " & vbCrLf & Encoding.Default.GetString(Encoding.Convert(Encoding.GetEncoding(866), Encoding.Default, Encoding.Default.GetBytes(e.Data))))
    End Sub
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        MyProcess.StandardInput.WriteLine(TextBox1.Text)
        MyProcess.StandardInput.Flush()
        TextBox1.Text = ""
    End Sub
    Private Sub AppendOutputText(ByVal text As String)
        Invoke(Sub()
                   TextBox2.AppendText(text) 'Добавление в строку для показа пользователю
               End Sub)
    End Sub
End Class
14
Вложения
Тип файла: zip CMD.zip (114.1 Кб, 200 просмотров)
Юпатов Дмитрий
1612 / 1124 / 224
Регистрация: 23.12.2010
Сообщений: 1,495
04.03.2013, 21:34 #40
Получение почты по протоколу POP3.
Создадим класс POP3.vb
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
Public Class Pop3
       ' ----- The default TCP/IP port number for POP3 is 110.
       Public Port As Integer = 110
       Public Messages As Integer = 0
 
       Private Const CommandFailure As String = "-ERR"
 
       Private Pop3Server As TcpClient
       Private CommandSender As NetworkStream
       Private ContentReceiver As StreamReader
 
       Public Sub Connect(ByVal serverName As String, _
             ByVal userName As String, ByVal password As String)
          ' ----- Initiate the connection to a POP3 server.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
          Dim parts() As String
 
          ' ----- Connect to the POP3 server.
          Try
             Pop3Server = New TcpClient(serverName, Port)
             CommandSender = Pop3Server.GetStream()
             ContentReceiver = New StreamReader(CommandSender)
          Catch
             Throw
          End Try
 
          If (userName <> "") Then
             ' ----- Authenticate with the user ID.
             commandData = "USER " & userName & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Invalid user name.")
             End If
 
             ' ----- Send the authenticating password.
             commandData = "PASS " & password & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Invalid password.")
             End If
          End If
 
          ' ----- Logged in. On some servers, the PASS command
          '       is not enough to push the server into a
          '       transaction state. Send a STAT command twice.
          commandData = "STAT" + vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
 
          ' ----- Get a count of the messages.
          commandData = "STAT" + vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
          If (Left(responseString, Len(CommandFailure)) = _
                CommandFailure) Then
             Throw New Exception( _
                "Could not retrieve message count.")
          End If
 
          ' ----- The response includes two integers: a count
          '       and a size, separated by a space. Skip over
          '       the "+OK" part also.
          parts = Split(responseString, " ")
          Messages = Val(parts(1))
       End Sub
 
       Public Sub Disconnect()
          ' ----- Disconnect from the  
POP3 server.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
 
          ' ----- Tell the server we're through.
          commandData = "QUIT" & vbCrLf
          contentBuffer = System.Text.Encoding.ASCII.GetBytes( _
             commandData.ToCharArray())
          CommandSender.Write(contentBuffer, 0, _
             contentBuffer.Length)
          responseString = ContentReceiver.ReadLine()
 
          ' ----- End the connection.
          ContentReceiver.Close()
          CommandSender.Close()
           
Pop3Server.Close()
       End Sub
 
       Function GetMessage(ByVal whichMessage As Integer) _
             As String
          ' ----- Retrieve a single email message.
          Dim commandData As String
          Dim contentBuffer() As Byte
          Dim responseString As String
          Dim theMessage As New System.Text.StringBuilder
          Dim oneLine As String
 
          ' ----- Check for an invalid message.
          If (whichMessage < 1) Or (whichMessage > Messages) Then
             Throw New ArgumentOutOfRangeException(whichMessage, _
                "Messages are numbered from 1 to the number " & _
                "identified by the Messages property.")
          End If
 
          Try
             ' ----- Request the message.
             commandData = "RETR " & whichMessage & vbCrLf
             contentBuffer = _
                System.Text.Encoding.ASCII.GetBytes( _
                commandData.ToCharArray())
             CommandSender.Write(contentBuffer, 0, _
                contentBuffer.Length)
             responseString = ContentReceiver.ReadLine()
             If (Left(responseString, Len(CommandFailure)) = _
                   CommandFailure) Then
                Throw New Exception("Message retrieval failed.")
             End If
 
             ' ----- The message is all data until a line with
             '       a single dot (.) appears.
             Do While (ContentReceiver.EndOfStream = False)
                oneLine = ContentReceiver.ReadLine()
                If (oneLine = ".") Then Exit Do
                theMessage.AppendLine(oneLine)
             Loop
          Catch ex As InvalidOperationException
             MsgBox("Message retrieval failed: " & ex.Message)
          End Try
 
          ' ----- Return the constructed message.
          Return theMessage.ToString()
       End Function
    End Class

Он у нас будет отвечать за получение списка писем с сервера и показ тела выбранного письма.
Теперь форма, см. рисунок "Форма1"
На ней:
three TextBox controls named . Set the UserPassword control's PasswordChar field to the asterisk character (*). Add a ListBox control named MessageList and two Button controls named ActGet and ActView. Set the Button controls' Text properties to Get Messages and View Message, respectively. Add informational labels if desired

3 TextBox с именами ServerName, UserName и UserPassword. Установите свойство PasswordChar последнего равным *. Добавьте ListBox с именем MessageList и 2 кнопки с именами ActGet и ActView. Установите свойство Text у кнопок равным Get Messages и View Message соответственно. По желанию добавьте метки (label) с пояснениями.
Полный код формы:
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Private POP3Connection As Pop3 = Nothing
 
    Private Sub ActGet_Click(ByVal sender As System.Object, _
          ByVal e As System.EventArgs) Handles ActGet.Click
       ' ----- Initiate a POP3 connection.
       Dim counter As Integer
 
       ' ----- First, disconnect any previous connection.
       If (POP3Connection IsNot Nothing) Then
          Try
             POP3Connection.Disconnect()
          Catch ex As Exception
             ' ----- Ignore.
          End Try
       End If
       POP3Connection = Nothing
 
       ' ----- Clear any previous messages.
       MessageList.Items.Clear()
 
       ' ----- Try the new connection.
       Try
           
POP3Connection = New Pop3
          POP3Connection.Connect(ServerName.Text, _
             UserName.Text, UserPassword.Text)
       Catch ex As Exception
          MsgBox("Connection failure: " & ex.Message)
          POP3Connection = Nothing
          Return
       End Try
 
       ' ----- How many messages?
       If (POP3Connection.Messages = 0) Then
          MsgBox("No messages found.")
          POP3Connection.Disconnect()
          POP3Connection = Nothing
          Return
       End If
 
       ' ----- Show each message.
       For counter = 1 To POP3Connection.Messages
          MessageList.Items.Add("Message Number " & counter)
       Next counter
    End Sub
 
    Private Sub ActView_Click(ByVal sender As System.Object, _
          ByVal e As System.EventArgs) Handles ActView.Click
       ' ----- Show a message.
       Dim whichMessage As Integer
       Dim parts As String()
       Dim content As String
 
       ' ----- Which message? Each item has the format:
       '          Message Number x
       If (MessageList.SelectedIndex = -1) Then Return
       parts = Split(CStr(MessageList.SelectedItem), " ")
       whichMessage = CInt(Val(parts(2)))
 
       ' ----- Get the content.
       content = POP3Connection.GetMessage(whichMessage)
 
       ' ----- Show the content.
       MsgBox(content)
    End Sub
 
    Private Sub MessageList_DoubleClick(ByVal sender As Object, _
          ByVal e As System.EventArgs) _
          Handles MessageList.DoubleClick
       ' ----- Same as the View button.
       ActView.PerformClick()
    End Sub
 
    Private Sub Form1_FormClosing(ByVal sender As Object, _
          ByVal e As System.Windows.Forms.FormClosingEventArgs) _
          Handles Me.FormClosing
       ' ----- Disconnect before leaving.
       On Error Resume Next
 
       If ( 
POP3Connection IsNot Nothing) Then
          POP3Connection.Disconnect()
          POP3Connection = Nothing
       End If
    End Sub

В итоге письма мы сможем увидеть в текстовом представлении. В том числе и вложения там будут в виде строки в кодировке Base64.
В целом рекомендую почитать и поизучать формат файлов .mht - именно в нем тело письма представлено. Добраться в него можно через класс CDO. Но это уже отдельная история (сам разбираюсь понемногу...)
Код не мой, но рабочий - проверено. Взят из книги: Visual Basic 2005 Cookbook (By John Clark Craig, Tim Patrick).
Для страждущих - книга приложена в архиве
13
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды  
Вложения
Тип файла: rar Visual_Basic_2005_Cookbook.rar (5.63 Мб, 358 просмотров)
04.03.2013, 21:34
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
04.03.2013, 21:34
Привет! Вот еще темы с решениями:

Хорошие учебники по Visual Basic Net
Подскажите пожалуйста хорошие учебники по visual basic net,спасибо

Как в Visual Basic .NET использовать CentimetersToPoints
В Visual Basic 6 можно было перевести сантиметры в пункты подобным образом CentimetersToPoints(х.хх) как подобное использовать в VB.NET ?

Для чего нужен Visual Basic.Net?
Здравствуйте. Объясните пожалуйста для какой деятельности нужен Visual Basic и Visual Basic.Net? То есть для чего там делают программы? И...

Перевести код с VBA на Visual Basic.NET
Здравствуйте! Прошу помощи. Переведите, пожалуйста, код ниже с VBA (Эксель) на Visual Basic.NET. Обращаюсь вынужденно, поскольку не...

Хорошие учебники по Visual Basic Net
Подскажите пожалуйста хорошие учебники по visual basic net,спасибо

Как в Visual Basic .NET использовать CentimetersToPoints
В Visual Basic 6 можно было перевести сантиметры в пункты подобным образом...

Для чего нужен Visual Basic.Net?
Здравствуйте. Объясните пожалуйста для какой деятельности нужен Visual Basic и...

Перевести код с VBA на Visual Basic.NET
Здравствуйте! Прошу помощи. Переведите, пожалуйста, код ниже с VBA (Эксель) на...


Искать еще темы с ответами

Или воспользуйтесь поиском по форуму:
40
Ответ Создать тему
Опции темы

КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru