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

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

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

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

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

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


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

Visual Basic .Net и Visual Basic 6.0 - В чём разница
В общем возник вопрос: Visual Bisic.Net и Visual Basic - это два разных языка,...

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 на...

195
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
13.11.2016, 20:36 #181
Как сделать курсор мыши [не]видимым в окне консоли?

Довольно распространенный вопрос, поэтому ниже приводится пример того, как это сделать с наименьшим количеством телодвижений.
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
Imports System.Threading
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    <DllImport("kernel32.dll", SetLastError := True)> _
    Friend Shared Function GetStdHandle( _
        ByVal nStdHandle As Int32 _
    ) As IntPtr
    End Function
    
    ' функция недокументирована, получена путем реверсинга
    <DllImport("kernel32.dll", SetLastError := True)> _
    Friend Shared Sub ShowConsoleCursor( _
        ByVal pStdHandle As IntPtr, _
        ByVal bShow As Boolean _
    )
    End Sub
  End Class
  
  Private Const STD_OUTPUT_HANDLE As Int32 = -11
  
  Shared Sub Main()
    ' скрываем курсор мыши в окне консоли
    NativeMethods.ShowConsoleCursor( _
      NativeMethods.GetStdHandle(STD_OUTPUT_HANDLE), False _
    )
    Thread.Sleep(3000)
    ' вновь делаем курсор видимым
    NativeMethods.ShowConsoleCursor( _
      NativeMethods.GetStdHandle(STD_OUTPUT_HANDLE), True _
    )
  End Sub
End Class
4
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
15.11.2016, 15:36 #182
Как программно вызвать одно из пунктов контекстного меню консоли?

Что-то очень много вопросов в ящике именно о консоли... На сей раз довольно много насчитал сообщений с вопросом о том, возможен ли скролл консоли без мыши, - как "Прокрутить" в меню по Alt+Space в пункте "Изменить".
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
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Function GetConsoleWindow _
    Lib "kernel32.dll" () As IntPtr
    
    Friend Declare Function SendMessageW _
    Lib "user32.dll" ( _
        ByVal hWnd As IntPtr, _
        ByVal Msg As UInt32, _
        ByVal wParam As IntPtr, _
        ByVal lParam As IntPtr _
    ) As IntPtr
  End Class
  
  Shared Sub Main
    NativeMethods.SendMessageW( _
      NativeMethods.GetConsoleWindow, _
      &H111, CType(&HFFF3, IntPtr), IntPtr.Zero
    )
  End Sub
End Class
Собственно это весь код. После компиляции и запуска вроде бы ничего не происходит, но стоит зажать клавишу со стрлкой вверх или вниз, как получим желаемую прокрутку. По аналогии "вызываются" прочие пункты контекстного меню, точнее достаточно в коде изменить значение &HFFF3 на одно из представленных ниже:
vb.net
1
2
3
4
5
&HFFF1 ' вставить
&HFFF2 ' пометить
&HFFF3 ' прокрутить
&HFFF4 ' найти
&HFFF5 ' выделить все
4
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
21.12.2016, 19:37 #183
Свойство OSVersion класса Environment возврвщает неверные данные о версии Windows, как это исправить?

Свойство OSVersion помечено M$ как deprecated, что в свою очередь указывает на нежелательное использование данного свойства, а оно, свойство, в свою очередь реализуется за счет вызовов API'шных функций с той же "черной меткой", что и OSVersion. (И как после этого не послать M$ в /dev/null?!) Однако, есть единственный (на данный момент) надежный способ извлечения версии системы - RtlGetNtVersionNumbers.
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
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Sub RtlGetNtVersionNumbers _
    Lib "ntdll.dll" ( _
        ByRef Major As UInt32, _
        ByRef Minor As UInt32, _
        ByRef Build As UInt32 _
    )
  End Class
  
  Shared Sub Main()
    Dim major As UInt32 = 0
    Dim minor As UInt32 = 0
    Dim build As UInt32 = 0
    
    NativeMethods.RtlGetNtVersionNumbers( _
       major, minor, build _
    )
    Console.WriteLine("{0}.{1}.{2}", _
       major, minor, build And &HFFFF
    )
  End Sub
End Class
2
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
29.12.2016, 11:26 #184
Как получить список альясов (макросов) консольных команд?

Заядлые консольщики обычно держат под рукой файл макросов команд, набор которых в консоли обычно занимает некоторое время; макросы же позволяют снизить это время за счет, например:
Windows Batch file
1
C:\> doskey which=for %i in (%pathext%) do @for %j in ($1%i) do @if exist "%~$PATH:j" @echo:%~$PATH:j
В итоге:
Windows Batch file
1
2
C:\> which reg
C:\Windows\System32\reg.exe
Так вот, подобные альясы (или все же макросы?!) имеют более высокий приоритет перед существуюшими командами. Допустим, задав такой макрос:
Windows Batch file
1
C:\> doskey ping=ping -n 10000 $1 | findstr /irc:"ttl"
При вызове ping будет выполняться именно команда выше, а не команда ping в ее обычном представлении. Как раз для того, чтобы избежать подобных недоразумений, полезно иногда поглядывать а был ли задан макрос. В самой консоли для этого имеется все тот же doskey, а вот программно это можно сделать так:
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
Imports System.Text
Imports System.Reflection
Imports System.ComponentModel
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    <DllImport("kernel32.dll", CharSet := CharSet.Unicode)> _
    Friend Shared Function GetConsoleAliases( _
        ByVal lpAliasBuffer As Byte(), _
        ByVal dwAliaseBufferLength As UInt32, _
        ByVal lpExeName As String _
    ) As UInt32
    End Function
 
    <DllImport("kernel32.dll", CharSet := CharSet.Unicode)> _
    Friend Shared Function GetConsoleAliasesLength( _
        ByVal lpExeName As String _
    ) As UInt32
    End Function
  End Class
 
  Shared Sub Main(ByVal args As String())
    If args.Length <> 1 Then
      Console.WriteLine( _
        "Usage: {0} [conapp]" & vbLf & ".e.g.: {0} cmd.exe", _
        GetType(Program).Assembly.GetName().Name
      )
      Return
    End If
 
    Dim sz As UInt32
    If (InlineAssignHelper( _
      sz, NativeMethods.GetConsoleAliasesLength(args(0)) _
    )) <= 0 Then
      Console.WriteLine("It seems that there are no aliases.")
      Return
    End If
 
    Dim buf As Byte() = New Byte(sz - 1) {}
    If NativeMethods.GetConsoleAliases(buf, sz, args(0)) = 0 Then
      Console.WriteLine(New Win32Exception( _
        Marshal.GetLastWin32Error() _
      ).Message)
      Return
    End If
 
    Console.WriteLine("[{0}]", args(0))
    Dim aliases As String() = Encoding.Unicode.GetString( _
      buf _
    ).Split(New Char() {ControlChars.NullChar})
    For Each [alias] As String In aliases
      Console.WriteLine("    {0}", [alias])
    Next
  End Sub
  
  Private Shared Function InlineAssignHelper(Of T)( _
      ByRef target As T, value As T _
  ) As T
    target = value
    Return value
  End Function
End Class

Существуют ли альтернативы свойству Is64BitOperatingSystem класса Environment?

Например, WMI (Win32_OperatingSystem), однако если у пользователя не окажется достаточно прав, узнать является ли система 64 битной или нет можно путем вызова GetNativeSystemInfo:
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
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
    
    Friend Declare Sub GetNativeSystemInfo _
    Lib "kernel32.dll" ( _
        ByRef lpSystemInfo As SYSTEM_INFO _
    )
  End Class
  
  <StructLayout(LayoutKind.Sequential)> _
  Friend Structure SYSTEM_INFO
    Friend wProcessorArchitecture As UInt16
    Friend wReserved As UInt16
    Friend dwPageSize As UInt32
    Friend lpMinimumApplicationAddress As IntPtr
    Friend lpMaximumApplicationAddress As IntPtr
    Friend dwActiveProcessorMask As UIntPtr
    Friend dwNumberOfProcessors As UInt32
    Friend dwProcessorType As UInt32
    Friend dwAllocationGranularity As UInt32
    Friend wProcessorLevel As UInt16
    Friend wProcessorRevision As UInt16
  End Structure
  
  Shared Sub Main()
    Dim si As New SYSTEM_INFO()
    NativeMethods.GetNativeSystemInfo(si)
    Console.WriteLine( _
      If (si.wProcessorArchitecture = 9, "64-bit", "32-bit")
    )
  End Sub
End Class
Согласно MSDN поле wProcessorArchitecture указывает на архитектуру процессора установленной системы. Альтернаивой же этому способу может быть вызов RtlGetNativeSystemInformation из ntdll, однако код будет несколько длинней, да и GetNativeSystemInfo по сути является оберткой для ее вызова.
2
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
08.03.2017, 22:06 #185
Как узнать тип охлаждения на текущий момент?
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
Imports System.ComponentModel
Imports System.Runtime.InteropServices
 
Friend NotInheritable Class Program
  Friend NotInheritable Class NativeMethods
    Private Sub New()
    End Sub
 
    Friend Declare Function NtPowerInformation Lib "ntdll.dll" ( _
        ByVal InformationLevel As UInt32, _
        ByVal InputBuffer As IntPtr, _
        ByVal InputBufferLength As UInt32, _
        ByRef OutputBuffer As SYSTEM_POWER_INFORMATION, _
        ByVal OutputBufferLength As UInt32 _
    ) As Int32
 
    Friend Declare Function RtlNtStatusToDosError Lib "ntdll.dll" ( _
        ByVal NtStatus As Int32 _
    ) As Int32
  End Class
 
  Friend Enum COOLING_MODE As Byte
    PO_TZ_ACTIVE
    PO_TZ_PASSIVE
    PO_TZ_INVALID_MODE
  End Enum
 
  <StructLayout(LayoutKind.Sequential)> _
  Friend Structure SYSTEM_POWER_INFORMATION
    Friend MaxIdlenessAllowed As UInt32
    Friend Idleness As UInt32
    Friend TimeRemaining As UInt32
    Friend _CoolingMode As COOLING_MODE
 
    Friend ReadOnly Property CoolingMode As String
      Get
        Return [Enum].GetName(GetType(COOLING_MODE), Me._CoolingMode)
      End Get
    End Property
  End Structure
 
  Private Const STATUS_SUCCESS As Int32 = 0
  Private Const SystemPowerInformation As UInt32 = 12
 
  Shared Sub Main()
    Dim spi As New SYSTEM_POWER_INFORMATION()
    Dim sz As UInt32 = Marshal.SizeOf(GetType(SYSTEM_POWER_INFORMATION))
    Dim nts As Int32
 
    nts = NativeMethods.NtPowerInformation( _
      SystemPowerInformation, IntPtr.Zero, 0, spi, sz _
    )
    If STATUS_SUCCESS <> nts Then
      Console.WriteLine(New Win32Exception( _
        NativeMethods.RtlNtStatusToDosError(nts) _
      ).Message)
      Return
    End If
 
    Console.WriteLine(spi.CoolingMode)
  End Sub
End Class
3
greg zakharov
Покинул форум
1942 / 818 / 234
Регистрация: 07.05.2015
Сообщений: 1,641
21.03.2017, 20:08 #186
Вычисление энтропии строки

Энтропия по Шеннону, как оговорка по Фрейду. Но это так, к слову. Ниже пример реализации вычисления оной.
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Imports System.IO
Imports System.Linq
 
Module Entropy
  Sub Main(ByVal args As String())
    If args.Length <> 1 Then
      Console.WriteLine("Синтаксис: {0} <строка>", _
        Path.GetFileName(Environment.GetCommandLineArgs()(0)) _
      )
      Return
    End If
 
    Dim arr As Char() = args(0).ToCharArray()
    Dim ent = arr.Distinct().Select( _
      Function(c) CType(arr.Count(Function(i) i = c), Double) / arr.Length _
    ).Select(Function(x) -(x) * Math.Log(x, 2)).Sum()
 
    Console.WriteLine("{0}", ent)
  End Sub
End Module
0
ViterAlex
6391 / 3595 / 1478
Регистрация: 11.02.2013
Сообщений: 7,919
Завершенные тесты: 3
17.06.2017, 20:21 #187
Как сделать курсор из битмапа?

Точка клика в центре битмапа
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
Imports System.Runtime.InteropServices
Module CursorModule
 
    <DllImport("user32.dll")>
    Private Function GetIconInfo(ByVal hIcon As IntPtr, ByRef piconinfo As IconInfo) As <MarshalAs(UnmanagedType.Bool)> Boolean : End Function
    <DllImport("user32.dll")>
    Private Function CreateIconIndirect(ByRef piconinfo As IconInfo) As IntPtr : End Function
    <DllImport("gdi32.dll")>
    Private Function DeleteObject(ByVal ptr As IntPtr) As <MarshalAs(UnmanagedType.Bool)> Boolean : End Function
 
    <StructLayout(LayoutKind.Sequential)>
    Private Structure IconInfo
        Public IsIcon As Boolean
        Public xHotspot As Integer
        Public yHotspot As Integer
        Public MaskBitmap As IntPtr
        Public ColorBitmap As IntPtr
    End Structure
 
    Public Function GetCursor(ByVal [bitmap] As Bitmap) As Cursor
        Dim hIcon = bitmap.GetHicon()
        Dim info = New IconInfo()
        GetIconInfo(hIcon, info)
 
        info.xHotspot = bitmap.Width / 2
        info.yHotspot = bitmap.Height / 2
        info.IsIcon = False
 
        hIcon = CreateIconIndirect(info)
        Dim result = New Cursor(hIcon)
        DeleteObject(hIcon)
        Return result
    End Function
End Module
4
ViterAlex
6391 / 3595 / 1478
Регистрация: 11.02.2013
Сообщений: 7,919
Завершенные тесты: 3
25.07.2017, 16:53 #188
Экспорт содержимого контрола, в данном случае ListView, в файлы различных типов. Например, txt, csv, html, docx, xlsx.
Какими инструментами пользоваться? С txt и csv всё понятно — обычный текст, пишем через поток. html тоже можно так писать, но лучше использовать XmlTextWriter — результат гораздо лучше выглядит.
Для офисных файлов можно пользоваться механизмом Interop: там довольно понятная объектная модель, однако очень низкая скорость и требуется установленный офис. Но главный минус — скорость. Поэтому я предлагаю использовать OpenXml. Объектная модель там посложнее, но получаемая скорость оправдывает затраченное время.
Для начала сделаем интерфейс экспортёра IExport:
vb.net
1
2
3
4
5
6
7
Imports System.Windows.Forms
 
Public Interface IExport
    Sub Save(path As String, lvw As ListView, Optional exportHeaders As Boolean = False)
    Property Extension() As String
    Property Description() As String
End Interface
Один метод и два свойства. Свойства не обязательны: они помогают упростить взаимодействие с экспортёром. Метод принимает в себя путь, ListView, который нужно сохранить и булевый параметр, нужно ли сохранять заголовки. Под заголовками имеются ввиду заголовки столбцов.
Реализацию интерфейса сделаем в абстрактном классе ExporterBase:
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
Imports System.Windows.Forms
 
Public MustInherit Class ExporterBase
    Implements IExport
    Friend _listView As ListView
    Friend _exportHeaders As Boolean
 
    Public Property Extension() As String Implements IExport.Extension
 
    Public Property Description() As String Implements IExport.Description
 
 
    Public Sub Save(path As String, lvw As ListView, Optional exportHeaders As Boolean = False) Implements IExport.Save
        _listView = lvw
        _exportHeaders = exportHeaders
        CreateFile(path)
    End Sub
 
    Friend MustOverride Sub CreateFile(path As String)
End Class
В этом классе пишем реализацию метода Save и объявляем абстрактный метод CreateFile, в котором наследники будут реализовывать конкрентный механизм экспорта.
Осталось написать реализацию пять классов для экспорта: TxtExporter, CsvExpoter, HtmlExporter, WordExporter, ExcelExporter. Приведу код HtmlExporter и WordExporter
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
Imports System.IO
Imports System.Windows.Forms
Imports System.Xml
 
Public Class HtmlExporter
    Inherits ExporterBase
 
    Friend Overrides Sub CreateFile(path As String)
        Using writer As New StreamWriter(path)
            Using xmlWr As New XmlTextWriter(writer) With {
                .Formatting = Formatting.Indented
                }
                xmlWr.WriteStartElement("html")
                xmlWr.WriteStartElement("head")
                xmlWr.WriteStartElement("style")
                xmlWr.WriteString(
                    "table{" +
                    "  border: 3px solid;" +
                    "  border-collapse: collapse;" +
                    "}" +
                    "th{" +
                    "  background-color: #888888;" +
                    "  border-left: 2px solid;" +
                    "}" +
                    "td{" +
                    "  border-left: 2px solid;" +
                    "}" +
                    "tr{" +
                    "  border-top: 1px solid;" +
                    "}")
                xmlWr.WriteEndElement() 'style
                xmlWr.WriteEndElement() 'head
                xmlWr.WriteStartElement("body")
                xmlWr.WriteStartElement("table")
                If _exportHeaders Then
                    AddHeader(xmlWr)
                End If
                For Each lvi As ListViewItem In _listView.Items
                    xmlWr.WriteStartElement("tr")
                    For Each lvsi As ListViewItem.ListViewSubItem In lvi.SubItems
                        xmlWr.WriteStartElement("td")
                        xmlWr.WriteString(lvsi.Text)
                        xmlWr.WriteEndElement() 'td
                    Next
                    xmlWr.WriteEndElement() 'tr
                Next
                xmlWr.WriteEndElement() 'table
                xmlWr.WriteEndElement() 'body
                xmlWr.WriteEndElement() 'html
            End Using
        End Using
    End Sub
 
    Private Sub AddHeader(writer As XmlTextWriter)
        writer.WriteStartElement("tr")
        For Each ch As ColumnHeader In _listView.Columns
            writer.WriteStartElement("th")
            writer.WriteString(ch.Text)
            writer.WriteEndElement() 'th
        Next
        writer.WriteEndElement() 'tr
    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
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
Imports System.Windows.Forms
Imports DocumentFormat.OpenXml
Imports DocumentFormat.OpenXml.Packaging
Imports DocumentFormat.OpenXml.Wordprocessing
 
Public Class WordExporter
    Inherits ExporterBase
    'Границы таблицы
    Private ReadOnly _tableBorders As BorderType() =
    {
        New TopBorder() With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 12,
            .Space = 0
        },
        New LeftBorder() With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 12,
            .Space = 0
        },
        New BottomBorder() With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 12,
            .Space = 0
        },
        New RightBorder() With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 12,
            .Space = 0
        },
        New InsideHorizontalBorder With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 6,
            .Space = 0
        },
        New InsideVerticalBorder With {
            .Val = BorderValues.Single,
            .Color = "auto",
            .Size = 6,
            .Space = 0
        }
    }
 
    Friend Overrides Sub CreateFile(path As String)
        Using package As WordprocessingDocument = WordprocessingDocument.Create(path, WordprocessingDocumentType.Document)
            CreateParts(package)
        End Using
    End Sub
 
 
    Private Sub CreateParts(document As WordprocessingDocument)
        Dim documentPart As MainDocumentPart = document.AddMainDocumentPart()
        GenerateMainDocumentPartContent(documentPart)
    End Sub
 
    'Генерирование содержимого документа
    Private Sub GenerateMainDocumentPartContent(documentPart As MainDocumentPart)
#Region " Минимальный набор данных для документа"
 
        Dim doc = New Document() With
        {
            .MCAttributes = New MarkupCompatibilityAttributes() With
            {
                .Ignorable = "w14 w15 w16se wp14"
            }
        }
        doc.AddNamespaceDeclaration("wp14", "http://schemas.microsoft.com/office/word/2010/wordprocessingDrawing")
        doc.AddNamespaceDeclaration("w", "http://schemas.openxmlformats.org/wordprocessingml/2006/main")
        doc.AddNamespaceDeclaration("w14", "http://schemas.microsoft.com/office/word/2010/wordml")
        doc.AddNamespaceDeclaration("w15", "http://schemas.microsoft.com/office/word/2012/wordml")
        doc.AddNamespaceDeclaration("w16se", "http://schemas.microsoft.com/office/word/2015/wordml/symex")
#End Region
        'К документу добавляем тело, к телу таблицу
        Dim tbl = doc.AppendChild(New Body()).AppendChild(New Table())
 
        With tbl.AppendChild(New TableProperties())
            'Добавляем границы таблицы
            .Append(New TableBorders(_tableBorders))
 
            'Добавляем отступы по умолчанию в ячейках таблицы 
            .Append(New TableCellMarginDefault With
            {
                .TableCellLeftMargin = New TableCellLeftMargin With {
                    .Width = CentimetersToPoints(0.2F),
                    .Type = TableWidthValues.Dxa
                },
                .TableCellRightMargin = New TableCellRightMargin With {
                    .Width = CentimetersToPoints(0.2F),
                    .Type = TableWidthValues.Dxa
                }
            })
        End With
 
        'Столбцы таблицы
        With tbl.AppendChild(New TableGrid())
            For i = 0 To _listView.Columns.Count - 1
                .Append(New GridColumn())
            Next
        End With
 
        'Если нужно — добавляем в таблицу первую строку с названиями столбцов ListView
        If _exportHeaders Then
            tbl.Append(GetHeader)
        End If
 
        'Заполнение таблицы
        For Each lvi As ListViewItem In _listView.Items
            With tbl.AppendChild(New TableRow())
                For Each lvsi As ListViewItem.ListViewSubItem In lvi.SubItems
                    'в строку добавляем ячейку, в ячейку — абзац, в абзац — фрагмент, во фрагмент — текст
                    .AppendChild(New TableCell()) _
                    .AppendChild(New Paragraph()) _
                    .AppendChild(New Run()) _
                    .Append(New Text() With {
                        .Text = lvsi.Text
                    })
                Next
            End With
        Next
        'Формирование документа
 
        documentPart.Document = doc
 
    End Sub
 
    'Создание строки-заголовка таблицы
    Private Function GetHeader() As TableRow
        Dim result As New TableRow()
        For Each ch As ColumnHeader In _listView.Columns
            'в строку добаляем ячейку
            With result.AppendChild(New TableCell()).AppendChild(New Paragraph())
                'в абзац добавляем выравнивание по центру
                .Append(New ParagraphProperties With {
                    .Justification = New Justification With {
                        .Val = JustificationValues.Center
                    }
                })
                'И фрагмент с текстом
                .AppendChild(New Run()).Append(New Text With {.Text = ch.Text})
            End With
        Next
        Return result
    End Function
 
    'Перевод сантиметров в точки
    Private Function CentimetersToPoints(centimeters As Single) As String
        Return CInt(centimeters * 28.34646F).ToString()
    End Function
End Class
На скриншоте примерное время выполнения тестов. Буква H в названии теста означает экспорт с заголовками.
В архиве решение с 3-мя проектами: библиотека exporters.dll, приложение WinForms для демонстрации и юнит тесты библиотеки exporters.
10
Изображения
 
Вложения
Тип файла: zip ExportListViewSolution.zip (49.5 Кб, 24 просмотров)
maks123123124
4 / 3 / 0
Регистрация: 25.06.2017
Сообщений: 36
Записей в блоге: 1
08.08.2017, 01:35 #189
Выключение или перезагрузка ПК

Выключение ПК:
vb.net
1
Shell("shutdown -s -t 0", vbHide)
Перезагрузка ПК:
vb.net
1
Shell("shutdown -r -t 0", vbHide)
4
17Vasya17
73 / 67 / 3
Регистрация: 05.01.2016
Сообщений: 278
24.09.2017, 10:33 #190
Работа с формой

Закрыть окно
Кликните здесь для просмотра всего текста
vb.net
1
Me.Close()


Свернуть окно
Кликните здесь для просмотра всего текста
vb.net
1
Me.WindowState = FormWindowState.Minimized


Развернуть свернуть на весь экран окно
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
      If Me.WindowState = FormWindowState.Normal Then
        Me.WindowState = FormWindowState.Maximized
      Else
        Me.WindowState = FormWindowState.Normal
      End If


Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Me.AcceptButton = Button1 'кнопка срабатывает при нажатии ENTER (OK)
        Me.CancelButton = Button2 'кнопка срабатывает при нажатии ESC (ОТМЕНА)
    End Sub


Тень для формы
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
 Private Const DROPSHADOW As Integer = &H20000
    Protected Overrides ReadOnly Property CreateParams() As CreateParams
        Get
            Dim myparam As CreateParams = MyBase.CreateParams
            myparam.ClassStyle = myparam.ClassStyle Or DROPSHADOW
            Return myparam 
        End Get
    End Property


Анимация Windows Form

Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
    Private Declare Function AnimateWindow Lib "user32" (ByVal hwnd As Long, ByVal dwTime As Long, ByVal dwFlags As Long) As Boolean
    Const AW_HOR_POSITIVE = &H1 'Анимация окна слева направо.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_HOR_NEGATIVE = &H2 'Анимация окна справа налево.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_VER_POSITIVE = &H4 'Анимация окна сверху вниз.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_VER_NEGATIVE = &H8 'Анимация окна снизу вверх.
    'Этот флаг используется совместно с эффектами развёртывания и соскальзывания.
    Const AW_CENTER = &H10 'Окно сворачивается внутрь себя если
    'установлен флаг AW_HIDE, иначе разворачивается
    Const AW_HIDE = &H10000 'Скрывает окно, по умолчанию окно появляется.
    Const AW_ACTIVATE = &H20000 'Активизирует окно.
    Const AW_SLIDE = &H40000 'Устанавливает эффект соскальзывания.
    'По умолчанию эффект развёртывания.
    Const AW_BLEND = &H80000 'Эффект постепенного появления.
    'Применяется только к окнам верхнего уровня.


Пример:

Кликните здесь для просмотра всего текста
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
'Плавный запуск формы
Imports System
Public Class Form1
 
    <Flags> _
    Enum AnimateWindowFlags
        AW_HOR_POSITIVE = &H1
        AW_HOR_NEGATIVE = &H2
        AW_VER_POSITIVE = &H4
        AW_VER_NEGATIVE = &H8
        AW_CENTER = &H10
        AW_HIDE = &H10000
        AW_ACTIVATE = &H20000
        AW_SLIDE = &H40000
        AW_BLEND = &H80000
    End Enum
    <System.Runtime.InteropServices.DllImport("user32.dll")> _
    Shared Function AnimateWindow(hWnd As IntPtr, time As Integer, flags As AnimateWindowFlags) As Boolean
    End Function
 
    Private Sub Form1_FormClosing(sender As Object, e As FormClosingEventArgs) Handles Me.FormClosing
        AnimateWindow(Me.Handle, 1000, AnimateWindowFlags.AW_BLEND Or AnimateWindowFlags.AW_HIDE)
    End Sub
 
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        AnimateWindow(Me.Handle, 1000, AnimateWindowFlags.AW_BLEND Or AnimateWindowFlags.AW_VER_POSITIVE)
    End Sub
3
Yury Komar
Модератор
Эксперт .NET
2368 / 2173 / 348
Регистрация: 27.01.2014
Сообщений: 3,912
Завершенные тесты: 1
01.11.2017, 13:14 #191
В данном посте решил собрать различные приемы для запуска своей (и не только) программы от имени администратора.
(Вопрос часто поднимается многими начинающими программистами, поэтому решил вынести ответ на него здесь)

Корректировка манифеста исполняемого файла:
Кликните здесь для просмотра всего текста
1) Переходим в настройки проекта [Обозреватель решений -> My Project]
2) Нажимаем на кнопку "Посмотреть параметры Windows", откроется файл манифеста приложения
3) Первое что необходимо сделать, это во второй строке в открывающем теге добавить атрибут
XML
1
xmlns:asmv3="urn:schemas-microsoft-com:asm.v3"
Полная строка будет выглядеть так:
XML
1
<asmv1:assembly manifestVersion="1.0" xmlns="urn:schemas-microsoft-com:asm.v1" xmlns:asmv1="urn:schemas-microsoft-com:asm.v1" xmlns:asmv2="urn:schemas-microsoft-com:asm.v2" xmlns:asmv3="urn:schemas-microsoft-com:asm.v3" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">
4) Далее находим строку
XML
1
<requestedExecutionLevel level="asInvoker" uiAccess="false" />
и заменяем данную строку на
XML
1
<requestedExecutionLevel  level="requireAdministrator" uiAccess="false" />
5) Для того, чтобы пользователю не выскакивало сообщение о том, что данное ПО требует прав администратора, нужно в конец маниваеста, перед закрывающим тегом </asmv1:assembly>, добавить следующее (это позволит приложению молча, не спрашивая пользователя, применить права админа):
XML
1
2
3
4
5
  <asmv3:application>
    <asmv3:windowsSettings xmlns="http://schemas.microsoft.com/SMI/2005/WindowsSettings">
      <autoElevate>true</autoElevate>
    </asmv3:windowsSettings>
  </asmv3:application>
После всего этого нужно сохранить проект и запустить ваш Visual Studio с правами администратора, либо при первом запуске она сама предложит вам это делать.
Вот и все, программа теперь будет запускаться с правами администратора, что без проблем позволит вам сохранить файлы на системном диске и так далее.

PS: На иконке исполняемого файла появится значок желто-синего щита.


Запуск какого-то файла с правами администратора
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
    Sub RunAsAdmin(FullPath As String, Optional Args As String = "", Optional WindowStyle As ProcessWindowStyle = ProcessWindowStyle.Normal, Optional UseShellExecute As Boolean = False)
        Dim pStartInfo As New ProcessStartInfo With {.FileName = FullPath, .Arguments = Args, .WindowStyle = WindowStyle, .UseShellExecute = UseShellExecute}
        If Environment.OSVersion.Version.Major >= 6 Then pStartInfo.Verb = "runas" 'Здесь проверяем, если ОС версия выше чем Vista, то применяем права администратора при запуске, до этой версии таких прав не нужно
        Process.Start(pStartInfo)
    End Sub


Через реестр установить у файла "галочку" на "Запускать от имени администратора"
Кликните здесь для просмотра всего текста
1) Рабочий раздел реестра: "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\AppCompatFlags\Layers"
2) Смотрим, есть ли в нем строковой параметр "REG_SZ" с именем равным "полному пути к EXE файлу"
3) Если нету, то создаешь новый параметр типа "REG_SZ" со значением "~ RUNASADMIN" (начало строки должно начинаться с символа "~", но и без него работает)
4) Если параметр с полным путем к нашему файлу уже существует, то нужно проверить нет ли у него в значении того, что мы хотим добавить.
5) Если того параметра в значении нет, то добавляем (через пробел) необходимое.
6) Если мы хотим отключить визуальные темы Windows у окна, то добавляем параметр DISABLETHEMES
7) Если мы хотим запускать программу в режиме совместимости с другой ОС, то добавляем ее короткое название (смотри ниже)

Режимы совместимости с различными ОС
WIN95 Windows 95
WIN98 Windows 98/Millenium
WINXPSP2 Windos XP Service Pack 2
WINXPSP3 Windos XP Service Pack 3
VISTARTM Windows Vista
VISTASP1 Windows Vista Service Pack 1
VISTASP2 Windows Vista Service Pack 2
WIN7RTM Windows 7
WIN8RTM Windows 8

Пример:
Имя параметра(путь к файлу): C:\MyApplication.exe
Значение параметра: ~ RUNASADMIN DISABLETHEMES WIN98
Описание: Запускает программу с правами администратора, отключает визуальные стили окна и работает в режиме совместимости с Win98


Узнать, запущена ли программа с правами администратора или нет
Кликните здесь для просмотра всего текста
vb.net
1
2
3
    Function IsAdministrator() As Boolean
        Return New Security.Principal.WindowsPrincipal(Security.Principal.WindowsIdentity.GetCurrent()).IsInRole(Security.Principal.WindowsBuiltInRole.Administrator)
    End Function


Узнать, входит ли тeкущий пользователь в группу Администраторов или другую нужную нам группу
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
    Public Function IsInGroup(ByVal GroupName As String) As Boolean
        Dim MyIdentity As System.Security.Principal.WindowsIdentity = System.Security.Principal.WindowsIdentity.GetCurrent()
        Dim MyPrincipal As System.Security.Principal.WindowsPrincipal = New System.Security.Principal.WindowsPrincipal(MyIdentity)
        Return MyPrincipal.IsInRole(GroupName)
    End Function
 
'Получить список групп можно таким образом:
    For Each groupName As String In System.Security.Principal.WindowsIdentity.GetCurrent.Groups.Select(Function(grp) grp.Translate(GetType(System.Security.Principal.NTAccount)).Value)
        ListBox1.Items.Add(groupName)
    Next





И еще немного полезностей:

Отловить событие MouseDown по заголовке кнопкам заголовка формы
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
    Protected Overrides Sub WndProc(ByRef m As System.Windows.Forms.Message)
        If m.Msg = &HA1 Then
            Select Case m.WParam
                Case 2
                    MsgBox("Form Title MouseDown")
                Case 3
                    MsgBox("Form Icon MouseDown. Called System Menu")
                Case 8
                    MsgBox("Minimize Button MouseDown")
                Case 9
                    MsgBox("Maximize Button MouseDown")
                Case 20
                    MsgBox("Form Close Button MouseDown")
            End Select
        End If
        MyBase.WndProc(m)
    End Sub






Заблокировать действия кнопок управления формой
Кликните здесь для просмотра всего текста
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
    Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Integer, ByVal bRevert As Integer) As Integer
    Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As wFlag) As Integer
    
    Enum wFlag
        MinButton = 3
        MaxButton = 4
        CloseButton = 6
    End Enum
 
    Public Sub KillingMenu(hWnd As Long, wFlag As wFlag)
        RemoveMenu(GetSystemMenu(hWnd, 0), wFlag, &H400&)
    End Sub

Пример (блокируем нажатие кнопки Развернуть на весь экран, тем самым блокируя и двойной клик по заголовку формы)
vb.net
1
KillingMenu(Me.Handle, wFlag.MaxButton)
7
Yury Komar
Модератор
Эксперт .NET
2368 / 2173 / 348
Регистрация: 27.01.2014
Сообщений: 3,912
Завершенные тесты: 1
29.12.2017, 19:08 #192
DTL, EVT File Reader

По мотивам найденного кода в сети и его копии на данном форуме сваял методы чтения бинарных файло DTL и EVT.
На самом деле в сети нет никакой информации по формату данных файлов, ну или я не смог найти. Долго мучился с ними, так как есть проекты, которын грузят данные выборок с PLC в базу данных ПО и без ужасных костылей не обходилось, что очень тормозило процесс импорта данных в базу.

Поэтому, чтоб не потерять, считаю код практически уникальным и выкладываю его на форум, надеюсь не я один с такими файлами намучался.
В архиве проект, сборка и примеры файлов с разными типами данных.

DTLreader.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
'// This code helps programmer to retrive a data from *DTL files.
'// The author of this code is Yury, Komar.
'// Public Function ReadDTL retirns a DataTable.
Module DtlReader
    Enum ValueType
        Int16_BCD_Unsigned = 0
        Int16_BCD_Signed = 1
        Int16_Unsigned = 2
        Int16_Signed = 3
        Int32_Unsigned = 4
        Int32_Signed = 5
        Float32 = 6
        String_ = 7
    End Enum
    Structure DTLColumn
        Public Type As ValueType, Size As Integer, Name As String
    End Structure
    Structure DTLHeader
        Public Sign As Integer, Undef1 As Integer, Date2 As Integer, FieldsCount As Integer, Count2 As Integer
        Public Columns() As DTLColumn
    End Structure
    Structure DTLRow
        Public Date_ As DateTime, Cells() As Object
    End Structure
 
    Public Function ReadDTL(FileName As String) As DataTable
        Dim newDT As New DataTable
        Using BinReader = New IO.BinaryReader(New IO.FileStream(FileName, IO.FileMode.Open, IO.FileAccess.Read), System.Text.Encoding.Default)
            Dim Header As DTLHeader
            Dim Rows As New DTLRow()
 
            'Read Header------------------------------------------------------------------------------------------------
            Header.Sign = BinReader.ReadInt32 'Not using in this code
            Header.Undef1 = BinReader.ReadInt32 'Not using in this code
            Header.Date2 = BinReader.ReadInt32 'Not using in this code
            Header.FieldsCount = BinReader.ReadInt32 'Read Columns number (+4 bytes)
            Header.Count2 = BinReader.ReadInt32 * 2 'Not using in this code
            Header.Columns = New DTLColumn(Header.FieldsCount - 1) {} 'Create empty array of Columns
            For i = 0 To Header.Columns.Count - 1 'Read each column's Type and Size
                Header.Columns(i).Type = BinReader.ReadInt32
                Header.Columns(i).Size = BinReader.ReadInt32
            Next
            BinReader.BaseStream.Position += 4 'skip 4 bytes
            For i = 0 To Header.Columns.Count - 1
                Header.Columns(i).Name = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(BinReader.ReadInt16))
                'MsgBox(Header.Columns(i).Name & vbCrLf & Header.Columns(i).Type) 'Check ColumnHeader Name and Type
            Next
 
            'Create DataTable Columns-------------------------------------------------------------------------------------
            newDT.Columns.Add("DateTime", GetType(System.DateTime))
            For Each f In Header.Columns
                If f.Type.ToString.Length > 0 Then newDT.Columns.Add(f.Name & StrDup(newDT.Columns.Count, vbNullChar))
            Next
 
            'ReadRowData ------------------------------------------------------------------------------------------------
            Do Until BinReader.BaseStream.Position = BinReader.BaseStream.Length
                Rows.Date_ = New DateTime(1970, 1, 1).AddSeconds(BinReader.ReadInt32).AddMilliseconds(BinReader.ReadByte)
                Rows.Cells = New Object(Header.Columns.Count - 1) {}
                For i = 0 To Header.Columns.Count - 1
                    Select Case Header.Columns(i).Type
                        Case ValueType.Int16_BCD_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_BCD_Signed
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_Signed
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int16_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt16
                        Case ValueType.Int32_Signed
                            Rows.Cells(i) = BinReader.ReadInt32
                        Case ValueType.Int32_Unsigned
                            Rows.Cells(i) = BinReader.ReadInt32
                        Case ValueType.Float32
                            Rows.Cells(i) = BinReader.ReadSingle
                        Case ValueType.String_
                            Rows.Cells(i) = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(Header.Columns(i).Size * 2))    'Read String with length * 2
                    End Select
                Next
 
                'Construct a new row and add it to the table-----------------------------------------------------------
                Dim Params As New List(Of Object)
                Params.Add(Rows.Date_)
                Params.AddRange((From r In Rows.Cells Where Not r Is Nothing).ToList)
                newDT.Rows.Add(Params.ToArray)
            Loop
        End Using
        Return newDT
        newDT.Dispose()
        GC.Collect()
    End Function
End Module

EVTreader.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
'// This code helps programmer to retrive a data from *EVT files.
'// The author of this code is Yury, Komar.
'// Public Function ReadEVT retirns a DataTable.
Module EVTreader
    Structure EVTHeader
        Public Sign, Undef1, Date2, Count As Integer
    End Structure
    Structure EVTRow
        Public Date_ As DateTime, Evnt As Byte, Catgry As Byte, Msg As String
    End Structure
 
    Public Function ReadEVT(FileName As String) As DataTable
        Dim newDT As New DataTable
        Using BinReader = New IO.BinaryReader(New IO.FileStream(FileName, IO.FileMode.Open, IO.FileAccess.Read), System.Text.Encoding.Default)
            Dim Header As EVTHeader
            Dim Rows As New EVTRow()
 
            'Read Header------------------------------------------------------------------------------------------------
            Header.Sign = BinReader.ReadInt32 'Not using in this code
            Header.Undef1 = BinReader.ReadInt32 'Not using in this code
            Header.Date2 = BinReader.ReadInt32 'Not using in this code
            Header.Count = BinReader.ReadInt32 '* 2 'Not using in this code
 
            'Create DataTable Columns-------------------------------------------------------------------------------------
            newDT.Columns.Add("DateTime", GetType(System.DateTime))
            newDT.Columns.Add("Event") ', GetType(System.DateTime))
            newDT.Columns.Add("Category") ', GetType(System.DateTime))
            newDT.Columns.Add("Message", GetType(System.String))
 
            'ReadRowData ------------------------------------------------------------------------------------------------
            Do Until BinReader.BaseStream.Position = BinReader.BaseStream.Length
                Rows.Date_ = New DateTime(1970, 1, 1).AddSeconds(BinReader.ReadInt32)
                Rows.Evnt = BinReader.ReadByte
                Rows.Catgry = BinReader.ReadByte
                Rows.Msg = System.Text.Encoding.UTF8.GetString(BinReader.ReadBytes(BinReader.ReadByte))
 
                'Construct a new row and add it to the table-----------------------------------------------------------
                Dim Params As New List(Of Object)
                Params.Add(Rows.Date_)
                Params.Add(Rows.Evnt)
                Params.Add(Rows.Catgry)
                Params.Add(Rows.Msg)
                newDT.Rows.Add(Params.ToArray)
            Loop
        End Using
        Return newDT
        newDT.Dispose()
        GC.Collect()
    End Function
End Module
8
Вложения
Тип файла: zip DTL Reader 1.0.1.zip (631.9 Кб, 11 просмотров)
GSXL
160 / 164 / 26
Регистрация: 26.11.2011
Сообщений: 382
Записей в блоге: 1
06.04.2018, 17:07 #193
SQLite, создание базы данных, установка, изменение и удаления пароля.

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
Imports System.Data.SQLite
Public Class Form1
 
    Dim PASSW As String
 
    Private Sub Button1_Click() Handles Button1.Click
 
 
        Dim sqConnection As New SQLiteConnection("Data Source=" & My.Computer.FileSystem.SpecialDirectories.Desktop & "\my_SQLite_DB.sqlite;Version=3;")
 
        sqConnection.Open()
 
        Dim sqCommand As New SQLiteCommand()
        sqCommand.Connection = sqConnection
        Dim myTrans As SQLiteTransaction
        myTrans = sqConnection.BeginTransaction()
        sqCommand.Transaction = myTrans
 
        Try
            sqCommand.CommandText = "CREATE TABLE 'Dept2' ('id' INTEGER PRIMARY KEY AUTOINCREMENT, 'rand' TEXT);"
            sqCommand.ExecuteNonQuery()
 
            For i = 1 To 1000
                sqCommand.CommandText = "INSERT INTO 'Dept2' ('rand') Values ('" & "Запись № " & i & "');"
                sqCommand.ExecuteNonQuery()
            Next
 
            myTrans.Commit()
            MsgBox("Ок")
        Catch e As Exception
            myTrans.Rollback()
            MsgBox(e.Message, MsgBoxStyle.Critical, "Ошибка")
        Finally
            sqConnection.Close()
        End Try
 
    End Sub
 
    Private Sub Button2_Click() Handles Button2.Click
        On Error Resume Next
        Dim SQL_COM As String
        Dim con As New SQLiteConnection("Data Source=" & My.Computer.FileSystem.SpecialDirectories.Desktop & "\my_SQLite_DB.sqlite; Version=3" & "; Password=" & PASSW & ";")
 
        SQL_COM = "SELECT * FROM Dept2 WHERE `id` = '160';"
 
        Dim sqlCom As New SQLiteCommand(SQL_COM, con)
        con.Open()
        'con.ChangePassword("")
        Dim SQLreader As SQLiteDataReader = sqlCom.ExecuteReader()
 
        If Err.Number <> 0 Then
            MsgBox("Ошибка " & Err.Number & ". " & Err.Description, MsgBoxStyle.Critical, "")
        Else
 
            While SQLreader.Read()
                MsgBox(SQLreader("rand"))
            End While
 
        End If
        con.Close()
    End Sub
 
    Private Sub Button3_Click() Handles Button3.Click
        On Error Resume Next
        Dim SQL_COM As String
        Dim con As New SQLiteConnection("Data Source=" & My.Computer.FileSystem.SpecialDirectories.Desktop & "\my_SQLite_DB.sqlite; Version=3" & "; Password=" & PASSW & ";")
 
        con.Open()
        PASSW = InputBox("Введите новый пароль для БД или оставьте пустым если пароль не нужен.", "")
        con.ChangePassword(PASSW)
 
        con.Close()
    End Sub
 
    Private Sub Button4_Click() Handles Button4.Click
        On Error Resume Next
        Dim SQL_COM As String
        Dim con As New SQLiteConnection("Data Source=" & My.Computer.FileSystem.SpecialDirectories.Desktop & "\my_SQLite_DB.sqlite; Version=3" & "; Password=" & PASSW & ";")
 
        con.Open()
 
        con.ChangePassword("")
 
        con.Close()
    End Sub
 
    Private Sub Button5_Click() Handles Button5.Click
        On Error Resume Next
        Dim SQL_COM As String
        Dim con As New SQLiteConnection("Data Source=" & My.Computer.FileSystem.SpecialDirectories.Desktop & "\my_SQLite_DB.sqlite; Version=3;")
 
        PASSW = InputBox("Введите пароль для БД или оставьте пустым если пароль не нужен.", "")
 
        con.Open()
        con.ChangePassword(PASSW)
        con.Close()
    End Sub
 
End Class
2
Миниатюры
Visual Basic .NET FAQ. Готовые решения, полезные коды  
Вложения
Тип файла: zip SQLite password.zip (1.37 Мб, 23 просмотров)
Sklifosofsky
757 / 693 / 172
Регистрация: 29.09.2015
Сообщений: 838
09.05.2018, 19:46 #194
Как открыть через оболочку Windows папку (и выделить в ней требуемые элементы)
Метод Shell.OpenFolderAndSelectItems(String, String[])

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
Module Shell
    Private Declare Auto Function _SHOpenFolderAndSelectItems Lib "Shell32.dll" Alias "SHOpenFolderAndSelectItems" _
        (pidlFolder As IntPtr, cidl As UInt32, <MarshalAs(UnmanagedType.LPArray)> apidl() As IntPtr, dwFlags As UInt32) As Int32
 
    Private Declare Auto Function _SHParseDisplayName Lib "Shell32.dll" Alias "SHParseDisplayName" _
        (<MarshalAs(UnmanagedType.LPWStr)> pszName As String, pbc As IntPtr, ByRef ppidl As IntPtr, sfgaoIn As UInt32, ByRef psfgaoOut As UInt32) As Int32
 
    ''' <summary>
    ''' Открывает через оболочку Windows указанный путь и выделяет элементы из коллекции имен
    ''' </summary>
    ''' <param name="Path">Путь к папке или файлу</param>
    ''' <param name="ItemNames">Коллекция имен выделяемых элементов в папке (Path)</param>
    ''' <remarks>Если указан только Path, то откроется родительская папка в которой находится этот элемент</remarks>
    Public Sub OpenFolderAndSelectItems(Path As String, ParamArray ItemNames() As String)
        Dim hResulut As Int32
        Dim pidlFolder As IntPtr
 
        hResulut = _SHParseDisplayName(Path, IntPtr.Zero, pidlFolder, 0, 0)
        Marshal.ThrowExceptionForHR(hResulut)
 
        Dim count As Int32 = CInt(If(ItemNames IsNot Nothing, ItemNames.Length, 0))
 
        Dim pidlCollection() As IntPtr = New IntPtr(count - 1) {}
 
        For i As Integer = 0 To count - 1
            hResulut = _SHParseDisplayName(IO.Path.Combine(Path, ItemNames(i)), IntPtr.Zero, pidlCollection(i), 0, 0)
            Marshal.ThrowExceptionForHR(hResulut)
        Next
 
        hResulut = _SHOpenFolderAndSelectItems(pidlFolder, CUInt(count), pidlCollection, 0)
        Marshal.ThrowExceptionForHR(hResulut)
    End Sub
End Module
3
ViterAlex
6391 / 3595 / 1478
Регистрация: 11.02.2013
Сообщений: 7,919
Завершенные тесты: 3
21.06.2018, 23:44 #195
Экспорт данных в документ Word
Ещё один вариант переноса значений в Word. Используется шаблон документа с закладками. Работает через OpenXml, поэтому только с форматом .docx. Не требует установленного Word.
Закладки могут иметь форматирование, но единое в пределах всей закладки. В противном случае, форматирование пропадёт.
В конечном документе закладки остаются.
Кликните здесь для просмотра всего текста
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
Imports DocumentFormat.OpenXml.Packaging
Imports DocumentFormat.OpenXml.Wordprocessing
 
Public Class DocumentFilling
    ''' <summary>
    ''' Заполнение документа на основе шаблона с закладками
    ''' </summary>
    ''' <param name="filename">Имя конечного документа.</param>
    ''' <param name="templatePath">Путь к шаблону.</param>
    ''' <param name="data">Словарь изменяемых закладок. Key — имя закладки, Value — новое значение.</param>
    Public Shared Sub Fill(filename As String, templatePath As String, data As IDictionary(Of String, String))
        Using doc = WordprocessingDocument.CreateFromTemplate(templatePath)
            ChangeBookmarks(doc, data)
            doc.SaveAs(filename)
        End Using
    End Sub
 
    Private Shared Sub ChangeBookmarks(doc As WordprocessingDocument, data As IDictionary(Of String, String))
        'Извлечение всех закладок в словарь с ключём по имени закладки
        Dim bm = doc.MainDocumentPart.RootElement.Descendants(Of BookmarkStart) _
            .ToDictionary(Function(bms)
                              Return bms.Name.ToString()
                          End Function)
 
        For Each item In data
            'Находим у закладки текстовую часть
            Dim r = bm(item.Key).NextSibling(Of Run)()
            If r IsNot Nothing Then
                'Удаляем текст закладки
                r.RemoveAllChildren(Of Text)()
                'Добавляем новый текст
                r.AppendChild(New Text(item.Value))
            End If
        Next
    End Sub
 
End Class

В приложенном файле проект библиотеки, пример использования в WinForms и тесты. После открытия решения нужно восстановить пакеты NuGet
3
Вложения
Тип файла: zip DocumentFilling.zip (48.5 Кб, 11 просмотров)
Sklifosofsky
757 / 693 / 172
Регистрация: 29.09.2015
Сообщений: 838
26.07.2018, 22:56 #196
Проецирование изображения (с анимацией) на другое окно вне зависимости от основного потока
Минимальная платформа .Net Framework 2.0

Вспомогательный класс ImageProjectionAsync, имеющий достаточный набор методов и свойств для проецирования изображения на окно или элемент окна по ссылке, поддерживающий отрисовку при помощи GDI.

За основу взята часть исходного кода System.Drawing.ImageAnimator (В отличии от которого частота кадров задается параметрами изображения, а не фиксированные 50мс, как было ранее)

Класс ImageProjectionAsync (Методы и свойства подписаны)
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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
Imports System
Imports System.Drawing
Imports System.Windows.Forms
Public Class ImageProjectionAsync
    Implements IDisposable
 
#Region "Declare methods"
    Private Declare Auto Function InvalidateRect Lib "User32.dll" (hWnd As IntPtr, lpRect As IntPtr, bErase As Boolean) As Boolean
    Private Declare Auto Function IsWindow Lib "User32.dll" (hWnd As IntPtr) As Boolean
#End Region
 
    Private _hWnd As IntPtr = IntPtr.Zero
    Private _rect As Rectangle
    Private _isWorking As Boolean = False
    Private _bkColor As Color
    Private _bg As BufferedGraphics
    Private _disposedValue As Boolean
    Private _syncObj As New Object()
    Private _imageHelper As ImageAnimatorHelper
    Private _timer As System.Timers.Timer
    Private _reverse As Boolean = False
    Private _infinity As Boolean = False
 
#Region "Methods"
    ''' <summary>
    ''' Инициализация
    ''' </summary>
    ''' <param name="TargetControl">Окно или компонент окна, на которое будет проецироваться изображение</param>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    Public Sub New(TargetControl As Control, ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        Me.New(TargetControl.Handle, ClipRectangle, BackColor, Image)
    End Sub
 
    ''' <summary>
    ''' Инициализация
    ''' </summary>
    ''' <param name="hWnd">Ссылка на окно или компонент окна, на которое будет проецироваться изображение</param>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    Public Sub New(hWnd As IntPtr, ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        If Not IsWindow(hWnd) Then
            Throw New Exception("hWnd не ссылается на окно или компонент окна")
        End If
 
        If Image Is Nothing Then
            Throw New NullReferenceException("Image")
        End If
 
        If ClipRectangle.Width <= 0 Or ClipRectangle.Height <= 0 Then
            Throw New Exception("Область рисования не должна иметь нулевые размеры")
        End If
 
        _hWnd = hWnd
        _rect = ClipRectangle
        _imageHelper = New ImageAnimatorHelper(Image)
        _bkColor = BackColor
 
        _timer = New System.Timers.Timer()
        AddHandler _timer.Elapsed, AddressOf OnFrameUpdate
 
        Me.CreateBufferedGraphics()
    End Sub
 
    Private Sub CreateBufferedGraphics()
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        Dim bc As BufferedGraphicsContext = BufferedGraphicsManager.Current
        bc.MaximumBuffer = New Size(_rect.Width, _rect.Height)
        _bg = bc.Allocate(Graphics.FromHwnd(_hWnd), _rect)
    End Sub
 
    ''' <summary>
    ''' Запуск проекции
    ''' </summary>
    Public Sub StartProjection()
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            If Not _isWorking Then
 
                _timer.Interval = 1.0R
                _timer.Start()
 
                _isWorking = True
            End If
        End SyncLock
    End Sub
 
    Private Sub OnFrameUpdate(sender As Object, e As System.Timers.ElapsedEventArgs)
        SyncLock _syncObj
 
            _imageHelper.UpdateFrame()
 
            Dim g As Graphics = _bg.Graphics
            g.Clear(_bkColor)
            g.DrawImage(_imageHelper.Image, _rect)
 
            If Not _infinity Then
                Dim delay As Double = CDbl(_imageHelper.FrameDelay(_imageHelper.Frame))
 
                If _timer.Interval <> delay Then
                    _timer.Interval = delay
                End If
            End If
 
            If _reverse Then
                _imageHelper.PreviousFrame()
            Else
                _imageHelper.NextFrame()
            End If
 
            Try
                _bg.Render()
            Catch
                Me.StopProjection()
                _hWnd = IntPtr.Zero
            End Try
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Остановка проекции
    ''' </summary>
    Public Sub StopProjection()
        SyncLock _syncObj
            If _isWorking Then
 
                _timer.Stop()
 
                InvalidateRect(_hWnd, IntPtr.Zero, True)
                _isWorking = False
            End If
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Вызов единовременного рисования на указанной поверхности вне зависимости от работы анимации. 
    ''' Так же можно вызывать между смены кадров при необходимости, если частота кадров очень низкая и указанная поверхность имеет свойства сбрасывать (перерисовывать) контентен (например, при изменении размеров элемента управления)
    ''' </summary>
    Public Sub Redraw()
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            Dim g As Graphics = _bg.Graphics
            g.Clear(_bkColor)
            g.DrawImage(_imageHelper.Image, _rect)
            Try
                _bg.Render()
            Catch
                Me.StopProjection()
                _hWnd = IntPtr.Zero
            End Try
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Присвоение новых параметров компоненту (при работе) 
    ''' </summary>
    ''' <param name="ClipRectangle"></param>
    ''' <param name="BackColor"></param>
    ''' <param name="Image"></param>
    Public Sub SetParams(ClipRectangle As Rectangle, BackColor As Color, Image As Image)
        Me.SetParams(ClipRectangle, BackColor, Image, 0)
    End Sub
 
    ''' <summary>
    ''' Присвоение новых параметров компоненту (при работе)
    ''' </summary>
    ''' <param name="ClipRectangle">Область рисования</param>
    ''' <param name="BackColor">Цвет подложки</param>
    ''' <param name="Image">Объект изображения (с анимацией)</param>
    ''' <param name="Frame">Текущий кадр</param>
    Public Sub SetParams(ClipRectangle As Rectangle, BackColor As Color, Image As Image, Frame As Integer)
        If _disposedValue Then
            Throw New Exception("Disposed")
        End If
 
        If Image Is Nothing Then
            Throw New NullReferenceException("Image")
        End If
 
        If ClipRectangle.Width <= 0 Or ClipRectangle.Height <= 0 Then
            Throw New Exception("Область рисования не должна иметь нулевые размеры")
        End If
 
        If _hWnd = IntPtr.Zero Then
            Return
        End If
 
        SyncLock _syncObj
            If _isWorking Then
                _timer.Stop()
                InvalidateRect(_hWnd, IntPtr.Zero, True)
            End If
 
            _rect = ClipRectangle
            Me.CreateBufferedGraphics()
            _bkColor = BackColor
            _imageHelper = New ImageAnimatorHelper(Image)
            If Frame < 0 Or Frame >= _imageHelper.FrameCount Then
                Throw New Exception("Индекс Frame выходит за пределы диапазона")
            End If
            _imageHelper.Frame = Frame
 
            If _isWorking Then
                _timer.Interval = 1.0R
                _timer.Start()
            End If
        End SyncLock
    End Sub
 
    ''' <summary>
    ''' Возвращает true, если объект изображения поддерживает анимацию
    ''' </summary>
    ''' <param name="Image">Объект изображения</param>
    ''' <returns>Bool</returns>
    Public Shared Function CanAnimate(Image As Image) As Boolean
        Dim dimensions() As System.Guid = Image.FrameDimensionsList
 
        For Each guid As System.Guid In dimensions
            Dim dimension As New System.Drawing.Imaging.FrameDimension(guid)
            If dimension.Equals(System.Drawing.Imaging.FrameDimension.Time) Then
                Return Image.GetFrameCount(System.Drawing.Imaging.FrameDimension.Time) > 1
            End If
        Next
        Return False
    End Function
#End Region
 
#Region "Properties"
    ''' <summary>
    ''' Возвращает состояние работы
    ''' </summary>
    ''' <returns>Bool</returns>
    Public ReadOnly Property IsWorking As Boolean
        Get
            Return _isWorking
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает состояние ссылки на окно. Если true, то ссылка была деструктуризированна и дальнейшая работа компонента невозможна
    ''' </summary>
    ''' <returns>Bool</returns>
    Public ReadOnly Property IsHandleDestroyed As Boolean
        Get
            Return (_hWnd = IntPtr.Zero)
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает фон подложки
    ''' </summary>
    ''' <returns>Bool</returns>
    Public Property BackColor As Color
        Get
            Return _bkColor
        End Get
        Set(value As Color)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                _bkColor = value
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает область рисования. Возможно изменение во время проецирования
    ''' </summary>
    ''' <returns>Rectangle</returns>
    Public Property ClipRectangle As Rectangle
        Get
            Return _rect
        End Get
        Set(value As Rectangle)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            If value.Width <= 0 Or value.Height <= 0 Then
                Throw New Exception("Область рисования не должна иметь нулевые размеры")
            End If
 
            SyncLock _syncObj
                If _isWorking Then
                    _timer.Stop()
                    InvalidateRect(_hWnd, IntPtr.Zero, True)
                End If
 
                _rect = value
                Me.CreateBufferedGraphics()
 
                If _isWorking Then
                    _timer.Interval = 1.0R
                    _timer.Start()
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает количество кадров
    ''' </summary>
    ''' <returns></returns>
    Public ReadOnly Property FrameCount As Integer
        Get
            Return _imageHelper.FrameCount
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает текущий кадр
    ''' </summary>
    ''' <returns></returns>
    Public Property CurrentFrame As Integer
        Get
            Return _imageHelper.Frame
        End Get
        Set(value As Integer)
            If value < 0 Or value >= _imageHelper.FrameCount Then
                Throw New Exception("Значение выходит за диапазон")
            End If
 
            SyncLock _syncObj
                _imageHelper.Frame = value
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает true, если указанное в конструкторе изображение поддерживает анимацию
    ''' </summary>
    ''' <returns></returns>
    Public ReadOnly Property Animated As Boolean
        Get
            Return _imageHelper.Animated
        End Get
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает свойство проигрывание анимации без задержки. 
    ''' Если указано true, то анимация будет проигрываться без указанной в свойствах изображения задержки
    ''' </summary>
    ''' <returns></returns>
    Public Property InfinityAnimate As Boolean
        Get
            Return _infinity
        End Get
        Set(value As Boolean)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                If _infinity <> value Then
 
                    _infinity = value
                    If _infinity Then
                        _timer.Interval = 1.0R
                    End If
 
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваивает свойство порядка проигрывания анимации. Если указано true, то анимация будет проигрываться в обратном порядке
    ''' </summary>
    ''' <returns></returns>
    Public Property ReverseAnimate As Boolean
        Get
            Return _reverse
        End Get
        Set(value As Boolean)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            SyncLock _syncObj
                If _reverse <> value Then
                    _reverse = value
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает\присваеивает текущее изображение компоненту
    ''' </summary>
    ''' <returns></returns>
    Public Property Image As Image
        Get
            Return _imageHelper.Image
        End Get
        Set(value As Image)
            If _disposedValue Then
                Throw New Exception("Disposed")
            End If
 
            If value Is Nothing Then
                Throw New NullReferenceException("Value")
            End If
 
            SyncLock _syncObj
                If _isWorking Then
                    _timer.Stop()
                End If
 
                _imageHelper = New ImageAnimatorHelper(value)
 
                If _isWorking Then
                    _timer.Interval = 1.0R
                    _timer.Start()
                End If
            End SyncLock
        End Set
    End Property
 
    ''' <summary>
    ''' Возвращает объект синхронизации. Для внешнего взаимодействия из других потоков
    ''' </summary>
    ''' <returns>Object</returns>
    Public ReadOnly Property SyncObject As Object
        Get
            Return _syncObj
        End Get
    End Property
#End Region
 
#Region "IDisposable"
    Protected Overridable Sub Dispose(disposing As Boolean)
        If Not _disposedValue Then
            If disposing Then
                Me.StopProjection()
                _bg.Dispose()
                _bg = Nothing
                _imageHelper = Nothing
            End If
        End If
        _disposedValue = True
    End Sub
 
    Public Sub Dispose() Implements IDisposable.Dispose
        Dispose(True)
    End Sub
#End Region
 
#Region "ImageAnimatorHelper"
    Private Class ImageAnimatorHelper
        Private Const __propertyTagTimeDelay As Integer = &H5100 ' ID свойства времени задежки кадров
 
        Private _image As Image
        Private _frame As Integer
        Private _frameCount As Integer
        Private _frameDelay() As Integer
        Private _frameDirty As Boolean
        Private _currentFrameDelay As Integer
        Private _animated As Boolean
 
#Region "Methods"
        Public Sub New(Image As Image)
            _image = Image
 
            _animated = ImageProjectionAsync.CanAnimate(_image)
 
            If _animated Then
                _frameCount = _image.GetFrameCount(Imaging.FrameDimension.Time)
 
                _frameDelay = New Integer(_frameCount - 1) {}
 
                Dim prop As Imaging.PropertyItem = _image.GetPropertyItem(__propertyTagTimeDelay)
                Debug.Assert(prop.Len = _frameCount * 4, "Размер буфера свойства не соответствует отношению количеству кадров")
 
                Dim buf() As Byte = prop.Value
 
                For i As Integer = 0 To _frameCount - 1
                    _frameDelay(i) = BitConverter.ToInt32(buf, i * 4) * 10
                    If _frameDelay(i) = 0 Then
                        _frameDelay(i) = 1
                    End If
                Next
            Else
                _frameCount = 1
                _frameDelay = New Integer() {1}
            End If
 
            _currentFrameDelay = _frameDelay(0)
        End Sub
 
        Public Sub UpdateFrame()
            If _frameDirty Then
                _image.SelectActiveFrame(Imaging.FrameDimension.Time, _frame)
                _frameDirty = False
            End If
        End Sub
 
        Public Sub NextFrame()
            If _animated Then
                _frame += 1
                If _frame = _frameCount Then
                    _frame = 0
                End If
                _currentFrameDelay = _frameDelay(_frame)
                _frameDirty = True
            End If
        End Sub
 
        Public Sub PreviousFrame()
            If _animated Then
                _frame -= 1
                If _frame < 0 Then
                    _frame = _frameCount - 1
                End If
                _currentFrameDelay = _frameDelay(_frame)
                _frameDirty = True
            End If
        End Sub
#End Region
 
#Region "Properties"
        Public Property Frame As Integer
            Get
                Return _frame
            End Get
            Set(value As Integer)
                If _frame <> value Then
 
                    Debug.Assert(value >= 0 And value < _frameCount, "Выход за пределы диапазона")
 
                    _frame = value
                    _currentFrameDelay = _frameDelay(_frame)
                    _frameDirty = True
                End If
            End Set
        End Property
 
        Public ReadOnly Property FrameCount As Integer
            Get
                Return _frameCount
            End Get
        End Property
 
        Public ReadOnly Property FrameDelay As Integer()
            Get
                Return _frameDelay
            End Get
        End Property
 
        Public ReadOnly Property FrameDirty As Boolean
            Get
                Return _frameDirty
            End Get
        End Property
 
        Public ReadOnly Property Animated As Boolean
            Get
                Return _animated
            End Get
        End Property
 
        Public ReadOnly Property Image As Image
            Get
                Return _image
            End Get
        End Property
 
        Public ReadOnly Property FrameLast As Boolean
            Get
                Return _frame = (_frameCount - 1)
            End Get
        End Property
 
        Public ReadOnly Property CurrentFrameDelay() As Integer
            Get
                Return _currentFrameDelay
            End Get
        End Property
#End Region
 
    End Class
 
#End Region
 
End Class


Пример 1
vb.net
1
2
3
4
5
6
7
        'Проецирование изображения на другое окно
        Dim proc() As Diagnostics.Process = Diagnostics.Process.GetProcessesByName("Notepad")
 
        If proc.Length > 0 Then
            Dim ipa As New ImageProjectionAsync(proc(0).MainWindowHandle, New Rectangle(0, 0, 100, 100), Color.White, [Image])
             ipa.StartProjection()
        End If


Пример 2
vb.net
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
        'Проецирование анимации в момент длительной обработки
        Dim panel As New Control()
        panel.Dock = DockStyle.Fill
 
        Me.Controls.Add(panel)
 
        panel.BringToFront()
 
        Dim ipa As New ImageProjectionAsync(panel.Handle, panel.ClientRectangle, Color.White, [Image])
        ipa.StartProjection()
 
        'длительная обработка
        'Threading.Thread.Sleep(10000)
 
        ipa.StopProjection()
        Me.Controls.Remove(panel)
4
26.07.2018, 22:56
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
26.07.2018, 22:56

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

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

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


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

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

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