Форум программистов, компьютерный форум CyberForum.ru
Наши страницы

Visual Basic

Войти
Регистрация
Восстановить пароль
 
 
Рейтинг: Рейтинг темы: голосов - 2, средняя оценка - 5.00
antonboom
bmstu-team
301 / 136 / 56
Регистрация: 10.01.2012
Сообщений: 420
Записей в блоге: 10
11.02.2013, 00:00 #31
Копирование формы
Непрограммный способ копирования нужной нам формы:
  1. File\Save Form1 As и сохраняем форму под другим именем
  2. File\Save Form1 As и сохраняем форму под старым именем с заменой файла

    Мы получили копию формы - просто файл (с другим именем), к которому наша программа не обращается.
  3. Меняем имя начальной формы на какое-нибудь другое, к примеру, Form11
  4. Project\Add File (Ctrl + D) и выбираем наш созданный в (2) файл
  5. Полная копия формы с элементами на ней загружена.

Не по теме:

Проверено на MS Visual Basic 6.0

3
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Similar
Эксперт
41792 / 34177 / 6122
Регистрация: 12.04.2006
Сообщений: 57,940
11.02.2013, 00:00
Здравствуйте! Я подобрал для вас темы с ответами на вопрос Готовые решения и полезные коды на Visual Basic 6.0 (Visual Basic):

Продам готовые коды и решения на Visual Basic за 400 рублей - Visual Basic
душу продаю:cry: Продам коды исходные на VB !!10 лет копил за 400р !!размер тока кодов 312метров там есть все ! мыло контакты удалены....

Коды на Visual Basic - Visual Basic
Ребята всем привет,я начел изучать "Visual Basic"! Очень буду благодарен за коды по этому языку, очень интиресный язык)))! Бросайте сюда...

Вывод решения вместо Immediate в textbox (visual basic 6.0) - Visual Basic
программа выводит решение в Immediate а я хочу разместить на форме text1 и что бы решение выводилось туда ,менял код менял не че не...

Вычисление значений функции двух переменных в Visual Basic - Visual Basic - Visual Basic
Помогите пожалуйста! В среде VB написать программу вычисления значений функции двух переменных. Ориентировочный вид окна программы и...

Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net ? - Visual Basic
Где бесплатно скачать учебник по Visual Basic 6 и Visual Basic .Net

Visual Basic Используя условный оператор if…then, if…then…else или if…then…elseif, разработайте проект для решения следующих заданий: - Visual Basic
Пройдет ли кирпич со сторонами а, b и с сквозь прямоугольное отверстие со сторонами p и q? Стороны отверстия должны быть параллельны граням...

Надоела реклама? Зарегистрируйтесь и она исчезнет полностью.
dev.Free
Заблокирован
17.02.2013, 16:09 #32
"Заморозить" Windows.

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
'Положите на форму элемент CommandButton
'Необходимое предупреждение: после выполнения данного кода компьютер 
'полностью блокируется, и перезагрузить его можно только кнопкой Restart на 
'вашем компьютере.
 
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Command1_Click()
    Dim freez
    
    freez = SetParent(Me.hWnd, Me.hWnd)
End Sub


Определить, как долго запущена Windows.

Кликните здесь для просмотра всего текста
Visual Basic
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
'Пример 1
'Этот пример покажет время в милисекундах (1000 миллисекунд = 1 секунда). 
'Если хотите получить секунды - разделите на 1000.
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Form_Load()
    MsgBox GetTickCount()
End Sub
 
'Более подробнее расписанная статистика.
 
Private Declare Function GetTickCount Lib "Kernel32" () As Long
 
Private Sub Command1_Click()
    Dim a_hour, a_minute, a_second
    a = Format(GetTickCount() / 1000, "0") 'всего секунд
    a_hour = Int(a / 3600)
    a = a - a_hour * 3600
    a_minute = Int(a / 60)
    a_second = a - a_minute * 60
    MsgBox "Ваш компьютер работает в эту загрузку " & str(a_hour) & " часов " & str(a_minute) & " минут" & str(a_second) & " секунд"
End Sub
 
'ИЛИ ТАКОЙ ПРИМЕР
'Расположите на форме элемент ListBox и элемент Timer
 
Private Declare Function GetTickCount& Lib "Kernel32" ()
 
Private Sub Form_Load()
    Timer1.Interval = 1000
End Sub
 
Private Sub Timer1_Timer()
    MS = GetTickCount()
    SekGesamt = MS \ 1000
    Std = (SekGesamt \ 3600)
    Min = (SekGesamt - (Std * 3600)) \ 60
    Sek = (SekGesamt - (Std * 3600) - (Min * 60))
    t = Format(Std, "00") & ":" & Format(Min, "00") & ":" & Format(Sek, "00")
    Label1.Caption = t
End Sub


Изменение внешнего вида кнопки ПУСК.

Кликните здесь для просмотра всего текста
Visual Basic
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
'Для изменения внешнего вида кнопки ПУСК вам нужна любая картинка 
'размером 55 пикс * 22 пикс. под именем temp.bmp
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
 
Const SRCCOPY = &HCC0020
 
Dim hwndTB As Long ' handle taskbar'а
Dim hWndSB As Long ' handle окна кнопки ПУСК
Dim hDcSB As Long ' handle содержимого кнопки ПУСК
Dim mRect As RECT ' координаты кнопки ПУСК
Dim hDcTmp As Long ' handle новой картинки
Dim hBmpTmp As Long ' временная картинка
Dim hBmpTmp2 As Long ' временная картинка
Dim nWidth As Long ' ширина кнопки ПУСК
Dim nHeight As Long ' высота кнопки ПУСК
Dim sPath As String ' путь к картинке
 
Private Sub Form_Load()
    ' получить handle taskbar и кнопки ПУСК
    hwndTB = FindWindow("Shell_TrayWnd", "")
    hWndSB = FindWindowEx(hwndTB, 0, "button", vbNullString)
    ' получить dc кнопки ПУСК
    hDcSB = GetWindowDC(hWndSB)
    ' получить координаты кнопки ПУСК
    Call GetWindowRect(hWndSB, mRect)
    ' ширина и высота
    nWidth = mRect.Right - mRect.Left
    nHeight = mRect.Bottom - mRect.Top
    hDcTmp = CreateCompatibleDC(hDcSB)
    hBmpTmp = CreateCompatibleBitmap(hDcTmp, nWidth, nHeight)
    ' установить путь для загрузки картинки
    sPath = App.Path & "\temp.bmp"
    hBmpTmp2 = SelectObject(hDcTmp, LoadPicture(sPath))
End Sub
 
Private Sub tmrPaint_Timer()
    ' рисовать кнопку ПУСК
    Call BitBlt(hDcSB, 0, 0, nWidth, nHeight, hDcTmp, 0, 0, SRCCOPY)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    ' очистить кнопку ПУСК
    hBmpTmp = SelectObject(hDcTmp, hBmpTmp2)
    DeleteObject hBmpTmp
    DeleteDC hDcTmp
End Sub


Меняем часики в трее на свои.

Кликните здесь для просмотра всего текста
Visual Basic
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
'На создавшейся вместе с проектом форме разместите таймер и метку. Имя 
'таймера timer1, interval = 50. Имя метки lblTime, Top = 0, left = 0
 
'Функция для поиска окна первого уровня
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Функция для поиска дочернего окна
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'Функция назначает окну нового родителя
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
 
Private Sub Form_Load()
    Dim hnd As Long
    
    'Часики является дочерним окном трея
    'И в свою очередь трей является дочерним окном панели задач
    'Ищем манипулятор панели задач (класс панели задач: Shell_TrayWnd)
    hnd = FindWindow("Shell_TrayWnd", vbNullString)
    'Ищем манипулятор трея (класс трея: TrayNotifyWnd)
    hnd = FindWindowEx(hnd, 0, "TrayNotifyWnd", vbNullString)
    'Ищем манипулятор часиков (класс часиков: TrayClockWClass)
    hnd = FindWindowEx(hnd, 0, "TrayClockWClass", vbNullString)
    'Вставляем нашу формы вместо часиков
    Me.Left = 0
    Me.Top = 0
    SetParent Me.hwnd, hnd
End Sub
 
Private Sub Timer1_Timer()
    lblTime = Time
End Sub


Заменяем системные цвета на свои собственные.

Кликните здесь для просмотра всего текста
Visual Basic
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
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
 
Private Declare Function GetSysColor& Lib "user32" (ByVal nIndex As Long)
 
'Можно использовать следующие константы
Private Const COLOR_SCROLLBAR = 0 'The Scrollbar colour
Private Const COLOR_BACKGROUND = 1 'Colour of the background With no wallpaper
Private Const COLOR_ACTIVECAPTION = 2 'Caption of Active Window
Private Const COLOR_INACTIVECAPTION = 3 'Caption of Inactive window
Private Const COLOR_MENU = 4 'Menu
Private Const COLOR_WINDOW = 5 'Windows background
Private Const COLOR_WINDOWFRAME = 6 'Window frame
Private Const COLOR_MENUTEXT = 7 'Window Text
Private Const COLOR_WINDOWTEXT = 8 '3D dark shadow (Win95)
Private Const COLOR_CAPTIONTEXT = 9 'Text in window caption
Private Const COLOR_ACTIVEBORDER = 10 'Border of active window
Private Const COLOR_INACTIVEBORDER = 11 'Border of inactive window
Private Const COLOR_APPWORKSPACE = 12 'Background of MDI desktop
Private Const COLOR_HIGHLIGHT = 13 'Selected item background
Private Const COLOR_HIGHLIGHTTEXT = 14 'Selected menu item
Private Const COLOR_BTNFACE = 15 'Button
Private Const COLOR_BTNSHADOW = 16 '3D shading of button
Private Const COLOR_GRAYTEXT = 17 'Grey text, of zero If dithering Is used.
Private Const COLOR_BTNTEXT = 18 'Button text
Private Const COLOR_INACTIVECAPTIONTEXT = 19 'Text of inactive window
Private Const COLOR_BTNHIGHLIGHT = 20 '3D highlight of button
 
Dim OldColor As Long
 
Private Sub Form_Load()
    'Эапоминаем текущий цвет
    OldColor = GetSysColor(COLOR_ACTIVECAPTION)
    
    SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 0, 0)
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    'Восстанавливаем текущий цвет
    SetSysColors 1, COLOR_ACTIVECAPTION, OldColor
End Sub


Получение информации о Windows, используя GetSystemInfo.

Кликните здесь для просмотра всего текста
Visual Basic
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
Private Type SYSTEM_INFO
    dwOemID As Long
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOrfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    dwReserved As Long
End Type
 
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type
 
Private Type MEMORYSTATUS
    dwLength As Long
    dwMemoryLoad As Long
    dwTotalPhys As Long
    dwAvailPhys As Long
    dwTotalPageFile As Long
    dwAvailPageFile As Long
    dwTotalVirtual As Long
    dwAvailVirtual As Long
End Type
 
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (LpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)
Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
 
Const PROCESSOR_INTEL_386 = 386
Const PROCESSOR_INTEL_486 = 486
Const PROCESSOR_INTEL_PENTIUM = 586
Const PROCESSOR_MIPS_R4000 = 4000
Const PROCESSOR_ALPHA_21064 = 21064
 
Sub SystemInformation()
    Dim msg As String ' Status information.
    Dim NewLine As String ' New-line.
    Dim ret As Integer ' OS Information
    Dim ver_major As Integer ' OS Version
    Dim ver_minor As Integer ' Minor Os Version
    Dim Build As Long ' OS Build
    NewLine = Chr(13) + Chr(10) ' New-line.
    ' Get operating system And version.
    Dim verinfo As OSVERSIONINFO
    
    verinfo.dwOSVersionInfoSize = Len(verinfo)
    ret = GetVersionEx(verinfo)
    If ret = 0 Then
        MsgBox "Error Getting Version Information"
        End
    End If
    'MsgBox verinfo.dwPlatformId
    Select Case verinfo.dwPlatformId
        Case 0
        msg = msg + "Windows 32s "
        Case 1
        msg = msg + "Windows 95 "
        Case 2
        msg = msg + "Windows NT "
    End Select
    
    ver_major = verinfo.dwMajorVersion
    ver_minor = verinfo.dwMinorVersion
    Build = verinfo.dwBuildNumber
    msg = msg & ver_major & "." & ver_minor
    msg = msg & " (Build " & Build & ")" & NewLine & NewLine
    
    ' Get CPU Type And operating mode.
    Dim sysinfo As SYSTEM_INFO
    GetSystemInfo sysinfo
    msg = msg + "CPU: "
    'MsgBox sysinfo.dwProcessorType
    Select Case sysinfo.dwProcessorType
        Case PROCESSOR_INTEL_386
        msg = msg + "Intel 386" + NewLine
        Case PROCESSOR_INTEL_486
        msg = msg + "Intel 486" + NewLine
        Case PROCESSOR_INTEL_PENTIUM
        msg = msg + "Intel Pentium" + NewLine
        Case PROCESSOR_MIPS_R4000
        msg = msg + "MIPS R4000" + NewLine
        Case PROCESSOR_ALPHA_21064
        msg = msg + "DEC Alpha 21064" + NewLine
        Case Else
        msg = msg + "(unknown)" + NewLine
    End Select
    msg = msg + NewLine
    ' Get free memory.
    Dim memsts As MEMORYSTATUS
    Dim memory As Long
    
    GlobalMemoryStatus memsts
    memory = memsts.dwTotalPhys
    msg = msg + "Total Physical Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwAvailPhys
    msg = msg + "Available Physical Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwTotalVirtual
    msg = msg + "Total Virtual Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    memory = memsts.dwAvailVirtual
    msg = msg + "Available Virtual Memory: "
    msg = msg + Format(memory \ 1024, "###,###,###") + "K" + NewLine
    MsgBox msg, vbOKOnly, "System Info"
End Sub
 
Private Sub Command1_Click()
    Call SystemInformation
End Sub


Поместить свою иконку в traybar.

Кликните здесь для просмотра всего текста
Visual Basic
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
Declare Function Shell_NotifyIconA Lib "SHELL32" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Integer
 
Public Const NIM_ADD = 0
Public Const NIM_MODIFY = 1
Public Const NIM_DELETE = 2
Public Const NIF_MESSAGE = 1
Public Const NIF_ICON = 2
Public Const NIF_TIP = 4
 
Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * 64
End Type
 
Public Function SetTrayIcon(Mode As Long, hWnd As Long, Icon As Long, tip As String) As Long
    Dim nidTemp As NOTIFYICONDATA
    nidTemp.cbSize = Len(nidTemp)
    nidTemp.hWnd = hWnd
    nidTemp.uID = 0&
    nidTemp.uFlags = NIF_ICON Or NIF_TIP
    nidTemp.uCallbackMessage = 0&
    nidTemp.hIcon = Icon
    nidTemp.szTip = tip & Chr$(0)
    SetTrayIcon = Shell_NotifyIconA(Mode, nidTemp)
End Function
 
Добавить в форму:
Private Sub Form_Click()
SetTrayIcon NIM_MODIFY, Me.hWnd, Me.Icon, "Работает? Работает!"
End Sub
Private Sub Form_Load()
SetTrayIcon NIM_ADD, Me.hWnd, Me.Icon, "Проверка"
End Sub
Private Sub Form_Unload(Cancel As Integer)
SetTrayIcon NIM_DELETE, Me.hWnd, 0&, ""
End Sub


Запуск сервисов Панели Управления.

Кликните здесь для просмотра всего текста
Visual Basic
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
'Если вы хотите запустить любую задачу из Панели Управления, вам достаточно 
'использовать функцию SHELL: Shell "rundll32.exe shell32.dll,Control_RunDLL " 
'& FileName, vbNormalFocus,
'где FileName - имя файла с расширением ".CPL", которые расположены в 
'директории %windir/system%
'Данный пример покажет все файлы с расширением ".CPL".
'Первая кнопка запускает проводник со всеми расширениями, вторая - запускает 
'конкретный сервис.
'Добавьте 2 CommandButton и 1 FileListBox на форму. Вставьте следующий код в 
'события формы.
 
Public Sub RunControlPanelExtension(FileName As String)
    Shell "rundll32.exe shell32.dll,Control_RunDLL " & FileName, vbNormalFocus
End Sub
 
Private Sub Command2_Click()
    RunControlPanelExtension File1.FileName
End Sub
 
Private Sub Command1_Click()
    Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus
End Sub
 
Private Sub Form_Load()
    File1.Pattern = "*.CPL"
    'В Windows NT замените 'C:\Windows\SYSTEM' на 'C:\WINNT\SYSTEM32'
    File1.FileName = "C:\Windows\SYSTEM"
End Sub
 
'Примеры использования:
 
'Установка оборудования
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", 5)
'Установка и удаление программ
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1", 5)
'Свойства экрана
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", 5)
'Настройки Интернета
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl,,0", 5)
'Клавиатура
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", 5)
'Мастер установки принтера
'Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus)
'Свойства модема
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", 5)
'Свойства мыши
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", 5)
'Настройки сети
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl", 5)
'Окно "Пароли"
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL password.cpl", 5)
'Окно "Язык и стандарты"
'Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0", 5)
'Окно "Звук"
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1", 5)
'Настройки системы
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0", 5)
'Настройка даты и времени
'Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", 5)
 
'ВАРИАНТ 2
'С использованием ShellExecute.
 
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 
Const SW_SHOWNORMAL = 1
 
Function StartCPLApp(AppName As String) As Long
    Dim Scr_hDC As Long
    
    Scr_hDC = GetDesktopWindow()
    MsgBox Scr_hDC
    StartCPLApp = ShellExecute(Scr_hDC, "Open", "Control", AppName, "C:\", SW_SHOWNORMAL)
End Function
 
Private Sub Command1_Click()
    StartCPLApp "DESK.CPL"
End Sub


Как сменить рисунок рабочего стола.

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
'Добавьте на форму 2 CommandButton. Первая кнопка помещает на рабочий стол 
'любой ваш рисунок, вторая - убирает этот рисунок.
 
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
 
Const SPI_SETDESKWALLPAPER = 20
 
Private Sub Command1_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, "D:\Basic\tmpProj\Load.bmp", True
    'Заменить путь D:\Basic\tmpProj\Load.bmp на нужный вам файл рисунка в формате bmp
End Sub
 
Private Sub Command2_Click()
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, 0, False
End Sub
6
Catstail
Модератор
22615 / 10976 / 1779
Регистрация: 12.02.2012
Сообщений: 18,114
19.02.2013, 12:50 #33
Изменение размера стека программы
Кстати, о размере стека... Вот моя небольшая программка, которая позволяет увеличить размер стека из PE-заголовка любого exe-файла. Менять можно оба поля (Reserved, Commited). Помогает. Я даже у самого vb6.exe увеличил размер стека.
6
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip SetStack.zip (9.4 Кб, 74 просмотров)
Craw
235 / 46 / 4
Регистрация: 10.06.2012
Сообщений: 268
Записей в блоге: 1
20.02.2013, 22:41 #34
Создание 3D объекта, его вращение, наложение текстур с помощью DirectX 8

Рисует цилиндр без дна и накладывает на него текстуру. Отсутствует освещение.
Код постарался закомментировать.

Развернуть код...
Visual Basic
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
Option Explicit
 
' создаем объекты DirectX, буферы и т.д.
Dim g_DX As New DirectX8
Dim g_D3D As Direct3D8
Dim g_D3DDevice As Direct3DDevice8
Dim g_VB As Direct3DVertexBuffer8
Dim g_D3DX As New D3DX8
Dim g_Texture As Direct3DTexture8
 
' здесь указываются вершины объекта
Private Type CUSTOMVERTEX
    Position As D3DVECTOR   '3d êîîðäèГ*Г*ГІГ» âåðøèГ*Г».
    color As Long           'Г–ГўГҐГІ âåðøèГ*Г».
    tu As Single            'ÊîîðäèГ*Г*ГІГ* òåêñòóðû.
    tv As Single            'ÊîîðäèГ*Г*ГІГ* òåêñòóðû.
End Type
 
Const D3DFVF_CUSTOMVERTEX = (D3DFVF_XYZ Or D3DFVF_DIFFUSE Or D3DFVF_TEX1)
' число пи
Const g_pi = 3.1415
 
Private Sub Form_Load()
'  инициализация DirectX, проверка на ошибки
Me.Show
If Not InitD3d(Form1.hWnd) Then
   MsgBox "ÍåâîçìîæГ*Г® ГЁГ*èöèГ*ëèçèðîâГ*ГІГј Direct3d."
   End
End If
If Not InitGeometry() Then
   MsgBox "ÍåâîçìîæГ*Г® ГЁГ*èöèГ*ëòçèðîâГ*ГІГј ГЎГіГґГҐГ° âåðøèГ*."
   End
End If
Timer1.Enabled = True
End Sub
 
Function InitD3d(hWnd As Long) As Boolean
On Local Error Resume Next '÷òîáû ïðè îøèáêå ïðîãðГ*ììГ* ïðîäîëæГ*Г«Г* Г°Г*áîòГ*ГІГј Г¤Г*ëüøå
 
Set g_D3D = g_DX.Direct3DCreate() 'ïîëó÷Г*ГҐГ¬ îáúåêò Direct3d
If g_D3D Is Nothing Then Exit Function  'åñëè Г*ГЁГ·ГҐГЈГ® Г*ГҐ ïðîèñõîäèò - âûõîä ГЁГ§ ГґГіГ*êöèè
 
Dim Mode As D3DDISPLAYMODE
g_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Mode
 
Dim d3dpp As D3DPRESENT_PARAMETERS
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
d3dpp.BackBufferFormat = Mode.Format
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
'ñîçäГ*ВёГ¬  ГіГ±ГІГ°Г®Г©Г±ГІГўГ® ðåГ*äåðèГ*ГЈГ*
Set g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _
                                     D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
If g_D3DDevice Is Nothing Then Exit Function
 
'âûêëþ÷Г*ГҐГ¬ culling
g_D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
'âêëþ÷Г*ГҐГ¬ z-áóôôåðèГ*ГЈ
g_D3DDevice.SetRenderState D3DRS_ZENABLE, 1
' отключаем 3D освещение
g_D3DDevice.SetRenderState D3DRS_LIGHTING, 0
 
InitD3d = True 'ГЁГ*èöèГ*ëèçГ*öèÿ Direct3d ïðîøëГ* ГіГ±ГЇГҐГёГ*Г®
End Function
 
Public Sub Render()
' в этой функции рендеринг всех объектов
Dim v As CUSTOMVERTEX
Dim sizeOfVertex As Long
 
g_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0
 
' ГЌГ*Г·Г*ëî ñöåГ*Г»
g_D3DDevice.BeginScene
' параметры текстуры
g_D3DDevice.SetTexture 0, g_Texture
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_MODULATE
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
g_D3DDevice.SetTextureStageState 0, D3DTSS_COLORARG2, D3DTA_DIFFUSE
g_D3DDevice.SetTextureStageState 0, D3DTSS_ALPHAOP, D3DTOP_DISABLE
' вызов матрицы
SetupMatrices
 
sizeOfVertex = Len(v)
g_D3DDevice.SetStreamSource 0, g_VB, sizeOfVertex
g_D3DDevice.SetVertexShader D3DFVF_CUSTOMVERTEX
g_D3DDevice.DrawPrimitive D3DPT_TRIANGLESTRIP, 0, (4 * 25) - 2
 
' ГЉГ®Г*ГҐГ¶ ñöåГ*Г»
g_D3DDevice.EndScene
' показываем это все
g_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
CleanUp
End Sub
 
Private Sub Timer1_Timer()
' интервал 40 мс, это частота рендеринга
Render
End Sub
 
Public Sub CleanUp()
' обязательная процедура по удалению всех объектов
' во избежание багов и глюков
Set g_D3DDevice = Nothing
Set g_D3D = Nothing
Set g_Texture = Nothing
Set g_VB = Nothing
Set g_D3DDevice = Nothing
Set g_D3D = Nothing
End Sub
 
Function InitGeometry() As Boolean
' функция, где рисуются все объекты
 
' от ошибок
On Local Error Resume Next
' загрузка текстуры
Set g_Texture = g_D3DX.CreateTextureFromFile(g_D3DDevice, App.Path + "\texture1.jpg")
If g_Texture Is Nothing Then Exit Function
 
Dim Vertices(99) As CUSTOMVERTEX
Dim VertexSizeInBytes As Long
 
VertexSizeInBytes = Len(Vertices(0))
 
Dim i As Long
Dim Theta As Single
' все объекты в DirectX - треугольники
' все рисуется из них
' чем больше треугольников и точнее пи, тем фигуры точнее
' у нас из 49 треугольников составляется цилиндр без дна
For i = 0 To 49
    Theta = (2 * g_pi * i) / (50 - 1)
    
    Vertices(2 * i + 0).Position = vec3(Sin(Theta), -1, Cos(Theta))
    Vertices(2 * i + 0).color = &HFFFFFFFF  'áåëûé.
    Vertices(2 * i + 0).tu = i / (50 - 1)
    Vertices(2 * i + 0).tv = 1
    
    Vertices(2 * i + 1).Position = vec3(Sin(Theta), 1, Cos(Theta))
    Vertices(2 * i + 1).color = &HFF808080  'ñåðûé.
    Vertices(2 * i + 1).tu = i / (50 - 1)
    Vertices(2 * i + 1).tv = 0
Next
 
Set g_VB = g_D3DDevice.CreateVertexBuffer(VertexSizeInBytes * 100, _
                 0, D3DFVF_CUSTOMVERTEX, D3DPOOL_DEFAULT)
If g_VB Is Nothing Then Exit Function
 
D3DVertexBuffer8SetData g_VB, 0, VertexSizeInBytes * 100, 0, Vertices(0)
 
InitGeometry = True
End Function
 
Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
    vec3.x = x
    vec3.y = y
    vec3.z = z
End Function
 
Public Sub SetupMatrices()
Dim matWorld As D3DMATRIX 'ГЊГ*òðèöГ* ГЊГЁГ°Г*
D3DXMatrixRotationAxis matWorld, vec3(1, 1, 1), Timer / 4
g_D3DDevice.SetTransform D3DTS_WORLD, matWorld
 
Dim matView As D3DMATRIX 'ГЊГ*òðèöГ* ÎáçîðГ*
D3DXMatrixLookAtLH matView, vec3(0, 3, -5), _
                            vec3(0, 0, 0), _
                            vec3(0, 1, 0)
                             
g_D3DDevice.SetTransform D3DTS_VIEW, matView
 
Dim matProj As D3DMATRIX 'ГЊГ*òðèöГ* Проекции
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000
g_D3DDevice.SetTransform D3DTS_PROJECTION, matProj
 
End Sub



Создание 3D модели, наложение текстуры и вращение с помощью DirectX 8

Используются сложные 3D модели формата .х. Можно создать с помощью 3D Max и конвертировать в .х.
Рисовать, например, автомобиль очень сложно через DirectX. Спасает использование моделей.

Развернуть код...
Visual Basic
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
'важно!
'd3dpp.AutoDepthStencilFormat = D3DFMT_D16
'Вместо D3DFMT_D16 надо использовать константу,
'соответствующую настройкам Вашего монитора.
 
Option Explicit
 
Dim g_DX As New DirectX8
Dim g_D3DX As New D3DX8
Dim g_D3D As Direct3D8
Dim g_D3DDevice As Direct3DDevice8
Dim g_Mesh As D3DXMesh                  ' Наш 3d объект
Dim g_MeshMaterials() As D3DMATERIAL8   ' Данные о материалах 3d объекта
Dim g_MeshTextures() As Direct3DTexture8 ' Текстуры 3d объекта
Dim g_NumMaterials As Long
 
Const g_pi = 3.1415
 
 
Private Sub Form_Load()
Me.Show
If Not InitD3d(Form1.hWnd) Then
   MsgBox "Невозможно инициализировать Direct3d."
   End
End If
If Not InitGeometry() Then
   MsgBox "Невозможно инициализировать буфер вершин."
   End
End If
Timer1.Enabled = True
End Sub
 
Function InitD3d(hWnd As Long) As Boolean
On Local Error Resume Next 'чтобы при ошибке программа продолжала работать дальше
 
Set g_D3D = g_DX.Direct3DCreate() 'получаем объект Direct3d
If g_D3D Is Nothing Then Exit Function  'если ничего не происходит - выход из функции
 
Dim Mode As D3DDISPLAYMODE
g_D3D.GetAdapterDisplayMode D3DADAPTER_DEFAULT, Mode
 
Dim d3dpp As D3DPRESENT_PARAMETERS
d3dpp.Windowed = 1
d3dpp.SwapEffect = D3DSWAPEFFECT_COPY_VSYNC
d3dpp.BackBufferFormat = Mode.Format
d3dpp.BackBufferCount = 1
d3dpp.EnableAutoDepthStencil = 1
d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
'создаём  устройство рендеринга
Set g_D3DDevice = g_D3D.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, _
                                     D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
If g_D3DDevice Is Nothing Then Exit Function
 
'выключаем culling
g_D3DDevice.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
'включаем z-буфферинг
g_D3DDevice.SetRenderState D3DRS_ZENABLE, 1
'выключаем 3d освещение
g_D3DDevice.SetRenderState D3DRS_LIGHTING, 0
 
InitD3d = True 'инициализация Direct3d прошла успешно
End Function
 
Public Sub Render()
Dim i As Long
 
g_D3DDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &HFF&, 1, 0
 
' Начало сцены
g_D3DDevice.BeginScene
 
SetupMatrices
 
' 3d объекты разделены на части (subsets).
' У каждой части свой материал и текстура.
' Рендеринг 3d объекта по частям в цикле:
For i = 0 To g_NumMaterials - 1
    ' Установка материала и текстуры для каждой части
    g_D3DDevice.SetMaterial g_MeshMaterials(i)
    g_D3DDevice.SetTexture 0, g_MeshTextures(i)
    ' Прорисовка части 3d объекта
    g_Mesh.DrawSubset i
Next
 
' Конец сцены
g_D3DDevice.EndScene
 
g_D3DDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
Cleanup
End Sub
 
Private Sub Timer1_Timer()
Render
End Sub
 
Sub Cleanup()
    Erase g_MeshTextures
    Erase g_MeshMaterials
    
    Set g_Mesh = Nothing
    Set g_D3DDevice = Nothing
    Set g_D3D = Nothing
End Sub
 
Function InitGeometry() As Boolean
On Local Error Resume Next
 
Dim MtrlBuffer As D3DXBuffer
Dim i As Long
 
Set g_Mesh = g_D3DX.LoadMeshFromX(App.Path + "\Tiger.x", D3DXMESH_MANAGED, _
                               g_D3DDevice, Nothing, MtrlBuffer, g_NumMaterials)
If g_Mesh Is Nothing Then Exit Function
 
ReDim g_MeshMaterials(g_NumMaterials)
ReDim g_MeshTextures(g_NumMaterials)
 
Dim strTexName As String
 
For i = 0 To g_NumMaterials - 1
    ' Копирование материала из буфера MtrlBuffer в массив g_MeshMaterials
    g_D3DX.BufferGetMaterial MtrlBuffer, i, g_MeshMaterials(i)
 
    ' Установка окружающего цвета материала (D3DX этого не делает)
    g_MeshMaterials(i).Ambient = g_MeshMaterials(i).diffuse
     
    ' Создание текстуры
    strTexName = g_D3DX.BufferGetTextureName(MtrlBuffer, i)
    If strTexName <> "" Then
        Set g_MeshTextures(i) = g_D3DX.CreateTextureFromFile(g_D3DDevice, App.Path + "\" + strTexName)
    End If
Next
 
Set MtrlBuffer = Nothing
 
InitGeometry = True
End Function
Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
    vec3.x = x
    vec3.y = y
    vec3.z = z
End Function
 
Public Sub SetupMatrices()
Dim matWorld As D3DMATRIX 'Матрица Мира
D3DXMatrixRotationY matWorld, Timer / 4
g_D3DDevice.SetTransform D3DTS_WORLD, matWorld
 
Dim matView As D3DMATRIX 'Матрица Обзора
D3DXMatrixLookAtLH matView, vec3(0, 3, -3), _
                            vec3(0, 0, 0), _
                            vec3(0, 1, 0)
                             
g_D3DDevice.SetTransform D3DTS_VIEW, matView
 
Dim matProj As D3DMATRIX 'Матрица Проекции
D3DXMatrixPerspectiveFovLH matProj, g_pi / 4, 1, 1, 1000
g_D3DDevice.SetTransform D3DTS_PROJECTION, matProj
 
End Sub


Создание 3D объекта, наложение текстуры, приближение и удаление с помощью DirectX 8

Этот пример я нашел, он куда сложнее. Потому без комментариев

frmD3D
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
Option Explicit
 
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = True
End Sub
 
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
  Keyb(KeyCode) = False
End Sub
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  If Running Then Cancel = 1: Running = False
End Sub
 
Private Sub TimerFPS_Timer()
  Me.Caption = FPS
  FPS = 0
End Sub

modAPI
Visual Basic
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
Option Explicit
 
Public Type POINTAPI
  x As Long
  y As Long
End Type
 
Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
 
Public Type int64
  dw1 As Long
  dw2 As Long
End Type
 
Public Declare Function QueryPerformanceCounter Lib "kernel32" (lpPerformanceCount As int64) As Long
Public Declare Function QueryPerformanceFrequency Lib "kernel32" (lpFrequency As int64) As Long
Dim QSpeed As Double
 
Public Function QTime() As Double
Dim QD As int64, t As Double
  QueryPerformanceCounter QD
  If QD.dw1 < 0& Then t = QD.dw1 + 4294967296# Else t = QD.dw1
  If QD.dw2 < 0& Then t = t + (QD.dw2 + 4294967296#) * 4294967296# Else t = t + QD.dw2 * 4294967296#
  QTime = t * QSpeed
End Function
 
Public Sub QFreqIni()
Dim QD As int64
  QueryPerformanceFrequency QD
  If QD.dw1 < 0& Then QSpeed = QD.dw1 + 4294967296# Else QSpeed = QD.dw1
  If QD.dw2 < 0& Then QSpeed = QSpeed + (QD.dw2 + 4294967296#) * 4294967296# Else QSpeed = QSpeed + QD.dw2 * 4294967296#
  QSpeed = 1# / QSpeed
End Sub

modeControl
Visual Basic
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
Option Explicit
 
Public Keyb(255) As Boolean
Public MouseSpeedX As Single
Public MouseSpeedY As Single
Public KeybSpeed As Single
Dim OldTime As Single
Dim Center As POINTAPI
 
Public Sub ControlInit()
Dim n As Long
  For n = 0 To 255
    Keyb(n) = False
  Next n
  OldTime = QTime
  'Center.x = Screen.Width \ Screen.TwipsPerPixelX \ 2
  'Center.y = Screen.Height \ Screen.TwipsPerPixelY \ 2
  'SetCursorPos Center.x, Center.y
End Sub
 
Public Sub DoControl()
Dim mPos As POINTAPI, t As Single
Dim dx As Single, dy As Single, dk As Single
  t = QTime
  dk = (t - OldTime) * KeybSpeed
  OldTime = t
 
 ' GetCursorPos mPos
 ' SetCursorPos Center.x, Center.y
  dx = (mPos.x - Center.x) * MouseSpeedX
  dy = (mPos.y - Center.y) * MouseSpeedY
  CameraAngle = CameraAngle + dx
  If CameraAngle < 0 Then CameraAngle = CameraAngle + 2 * Pi
  If CameraAngle > 2 * Pi Then CameraAngle = CameraAngle - 2 * Pi
  CameraDiff = CameraDiff + dy
  If CameraDiff < -0.5 * Pi Then CameraDiff = -0.5 * Pi
  If CameraDiff > 0.5 * Pi Then CameraDiff = 0.5 * Pi
 
  If Keyb(vbKeyLeft) Then
    CameraPos.x = CameraPos.x - Cos(CameraAngle) * dk
    CameraPos.z = CameraPos.z - Sin(CameraAngle) * dk
  End If
  If Keyb(vbKeyRight) Then
    CameraPos.x = CameraPos.x + Cos(CameraAngle) * dk
    CameraPos.z = CameraPos.z + Sin(CameraAngle) * dk
  End If
  If Keyb(vbKeyUp) Then
    CameraPos.x = CameraPos.x - Sin(CameraAngle) * dk
    CameraPos.z = CameraPos.z + Cos(CameraAngle) * dk
  End If
  If Keyb(vbKeyDown) Then
    CameraPos.x = CameraPos.x + Sin(CameraAngle) * dk
    CameraPos.z = CameraPos.z - Cos(CameraAngle) * dk
  End If
  If Keyb(vbKeyA) Then
    SunAngle = SunAngle - dk
    If SunAngle < 0 Then SunAngle = SunAngle + 2 * Pi
  End If
  If Keyb(vbKeyD) Then
    SunAngle = SunAngle + dk
    If SunAngle > 2 * Pi Then SunAngle = SunAngle - 2 * Pi
  End If
  If Keyb(vbKeyW) Then
    SunDiff = SunDiff + dk
    If SunDiff > 0.5 * Pi Then SunDiff = 0.5 * Pi
  End If
  If Keyb(vbKeyS) Then
    SunDiff = SunDiff - dk
    If SunDiff < 0 Then SunDiff = 0
  End If
End Sub

modDX
Visual Basic
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
Option Explicit
 
Public Enum TexF
  TexF_None
  TexF_BiLinear
  TexF_TriLinear
  TexF_Anisotropic
End Enum
 
Public dx8 As New DirectX8
Public d3d As Direct3D8
Public d3dx As New D3DX8
Public d3dDevice As Direct3DDevice8
Public Caps As D3DCAPS8
Public Const Pi = 3.141593
 
Public Sub TexFilter(Stage As Long, TF As TexF, Optional MaxAnisotropy As Long = 2)
  Select Case TF
    Case TexF_None
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_NONE
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_NONE
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_NONE
    Case TexF_BiLinear
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_POINT
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
    Case TexF_TriLinear
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
    Case TexF_Anisotropic
      d3dDevice.SetTextureStageState Stage, D3DTSS_MIPFILTER, D3DTEXF_LINEAR
      d3dDevice.SetTextureStageState Stage, D3DTSS_MAGFILTER, D3DTEXF_LINEAR
      If Caps.MaxAnisotropy >= MaxAnisotropy Then
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_ANISOTROPIC
        d3dDevice.SetTextureStageState Stage, D3DTSS_MAXANISOTROPY, MaxAnisotropy
      ElseIf Caps.MaxAnisotropy >= 2 Then
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_ANISOTROPIC
        d3dDevice.SetTextureStageState Stage, D3DTSS_MAXANISOTROPY, Caps.MaxAnisotropy
      Else
        d3dDevice.SetTextureStageState Stage, D3DTSS_MINFILTER, D3DTEXF_LINEAR
      End If
  End Select
End Sub
 
Public Sub D3DInit(hWnd As Long)
Dim DispMode As D3DDISPLAYMODE
Dim d3dpp As D3DPRESENT_PARAMETERS
 
  Set d3d = dx8.Direct3DCreate
  d3d.GetDeviceCaps D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, Caps
  d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, DispMode
 
  d3dpp.Windowed = True
  d3dpp.SwapEffect = D3DSWAPEFFECT_DISCARD
  d3dpp.BackBufferFormat = DispMode.Format
  d3dpp.BackBufferCount = 1
  d3dpp.EnableAutoDepthStencil = True
  d3dpp.AutoDepthStencilFormat = D3DFMT_D16
 
  Set d3dDevice = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, hWnd, D3DCREATE_SOFTWARE_VERTEXPROCESSING, d3dpp)
End Sub
 
Public Sub D3DTerminate()
  Set d3dx = Nothing
  Set d3dDevice = Nothing
  Set d3d = Nothing
  Set dx8 = Nothing
End Sub
 
Public Function vec3(x As Single, y As Single, z As Single) As D3DVECTOR
  vec3.x = x
  vec3.y = y
  vec3.z = z
End Function
 
Public Function vec2(x As Single, y As Single) As D3DVECTOR2
  vec2.x = x
  vec2.y = y
End Function

modMain
Visual Basic
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
Option Explicit
 
Private Type vFormat
  Pos As D3DVECTOR
  Normal As D3DVECTOR
  tu0 As Single
  tv0 As Single
End Type
 
Public Running As Boolean
Public FPS As Long
Public CameraPos As D3DVECTOR
Public CameraAngle As Single
Public CameraDiff As Single
Public SunAngle As Single
Public SunDiff As Single
Dim Light As D3DLIGHT8
Dim Mesh As D3DXMesh
Dim Tex0 As Direct3DTexture8
Dim Tex1 As Direct3DTexture8
 
Public Sub Main()
Dim Mtrx As D3DMATRIX
  frmD3D.Show
  QFreqIni
  D3DInit frmD3D.hWnd
  ControlInit
  InitMatrix
  InitMesh
  Setting
  InitLight
  InitMaterial
  CameraPos = vec3(0, 0, -3)
  CameraAngle = 0
  CameraDiff = 0
  SunAngle = 0
  SunDiff = Pi / 4
  MouseSpeedX = -0.002
  MouseSpeedY = -0.002
  KeybSpeed = 2
  Running = True
'  ShowCursor 0
  Do While Running
    DoEvents
    DoControl
    CameraSet
    Render
    FPS = FPS + 1
  Loop
'  ShowCursor 1
  ClearAll
  Unload frmD3D
End Sub
 
Private Sub Setting()
  Set Tex0 = d3dx.CreateTextureFromFile(d3dDevice, "BrickDot.tga")
  d3dDevice.SetTexture 0, Tex0
  TexFilter 0, TexF_TriLinear
  Set Tex1 = d3dx.CreateTextureFromFile(d3dDevice, "dot.tga")
  d3dDevice.SetTexture 1, Tex1
  TexFilter 1, TexF_TriLinear
 
  d3dDevice.SetTextureStageState 0, D3DTSS_COLOROP, D3DTOP_SELECTARG1
  d3dDevice.SetTextureStageState 0, D3DTSS_COLORARG1, D3DTA_TEXTURE
 
  d3dDevice.SetTextureStageState 1, D3DTSS_COLOROP, D3DTOP_DOTPRODUCT3
  d3dDevice.SetTextureStageState 1, D3DTSS_COLORARG1, D3DTA_TEXTURE
  d3dDevice.SetTextureStageState 1, D3DTSS_COLORARG2, D3DTA_CURRENT
  d3dDevice.SetTextureStageState 1, D3DTSS_TEXCOORDINDEX, D3DTSS_TCI_CAMERASPACENORMAL
  d3dDevice.SetTextureStageState 1, D3DTSS_TEXTURETRANSFORMFLAGS, D3DTTFF_COUNT2
 
  d3dDevice.SetTextureStageState 2, D3DTSS_COLOROP, D3DTOP_MODULATE2X
  d3dDevice.SetTextureStageState 2, D3DTSS_COLORARG1, D3DTA_DIFFUSE
  d3dDevice.SetTextureStageState 2, D3DTSS_COLORARG2, D3DTA_CURRENT
 
  d3dDevice.SetRenderState D3DRS_LIGHTING, 1
  d3dDevice.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
End Sub
 
Private Sub CameraSet()
Dim Mtrx As D3DMATRIX, v As D3DVECTOR
  D3DXMatrixRotationX Mtrx, CameraDiff
  d3dDevice.SetTransform D3DTS_VIEW, Mtrx
  D3DXMatrixRotationY Mtrx, CameraAngle
  d3dDevice.MultiplyTransform D3DTS_VIEW, Mtrx
  D3DXMatrixTranslation Mtrx, -CameraPos.x, -CameraPos.y, -CameraPos.z
  d3dDevice.MultiplyTransform D3DTS_VIEW, Mtrx
 
  D3DXMatrixTranslation Mtrx, 0.5, 0.5, 0
  d3dDevice.SetTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixScaling Mtrx, 0.5, 0.5, 1
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixRotationX Mtrx, SunDiff - CameraDiff
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
  D3DXMatrixRotationY Mtrx, SunAngle - CameraAngle
  d3dDevice.MultiplyTransform D3DTS_TEXTURE1, Mtrx
 
  D3DXMatrixRotationX Mtrx, -SunDiff
  D3DXVec3TransformCoord v, vec3(0, 0, 1), Mtrx
  D3DXMatrixRotationY Mtrx, -SunAngle
  D3DXVec3TransformCoord v, v, Mtrx
  Light.Direction = v
  d3dDevice.SetLight 0, Light
End Sub
 
Private Sub InitLight()
  Light.Type = D3DLIGHT_DIRECTIONAL
  Light.diffuse.r = 0.7
  Light.diffuse.g = 0.7
  Light.diffuse.b = 0.7
  d3dDevice.LightEnable 0, 1
End Sub
 
Private Sub InitMaterial()
Dim Mat As D3DMATERIAL8
  Mat.diffuse.r = 1
  Mat.diffuse.g = 1
  Mat.diffuse.b = 1
  d3dDevice.SetMaterial Mat
End Sub
 
Private Sub Render()
  d3dDevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, &H345599, 1, 0
  d3dDevice.BeginScene
 
  Mesh.DrawSubset 0
 
  d3dDevice.EndScene
  d3dDevice.Present ByVal 0, ByVal 0, 0, ByVal 0
End Sub
 
Private Sub InitMesh()
Dim vBuf As Direct3DVertexBuffer8, iBuf As Direct3DIndexBuffer8
Dim n As Long, Vert() As vFormat, Ind() As Integer
  Set Mesh = d3dx.CreateMeshFVF(128, 130, 0, D3DFVF_XYZ Or D3DFVF_NORMAL Or D3DFVF_TEX1, d3dDevice)
  
  Set vBuf = Mesh.GetVertexBuffer
  ReDim Vert(129)
  For n = 0 To 128 Step 2
    Vert(n + 0).Pos = vec3(Sin(2 * Pi * n / 128), 0.7, Cos(2 * Pi * n / 128))
    Vert(n + 0).Normal = vec3(Sin(2 * Pi * n / 128), 0, Cos(2 * Pi * n / 128))
    Vert(n + 0).tv0 = 0
    Vert(n + 0).tu0 = -n * 4 / 128
    Vert(n + 1).Pos = vec3(Sin(2 * Pi * n / 128), -0.7, Cos(2 * Pi * n / 128))
    Vert(n + 1).Normal = vec3(Sin(2 * Pi * n / 128), 0, Cos(2 * Pi * n / 128))
    Vert(n + 1).tv0 = 1
    Vert(n + 1).tu0 = -n * 4 / 128
  Next n
  D3DVertexBuffer8SetData vBuf, 0, 130 * Len(Vert(0)), 0, Vert(0)
  Set vBuf = Nothing
 
  Set iBuf = Mesh.GetIndexBuffer
  ReDim Ind(3 * 128 - 1)
  For n = 0 To 63
    Ind(n * 6 + 0) = n * 2 + 0
    Ind(n * 6 + 1) = n * 2 + 1
    Ind(n * 6 + 2) = n * 2 + 3
    Ind(n * 6 + 3) = n * 2 + 0
    Ind(n * 6 + 4) = n * 2 + 3
    Ind(n * 6 + 5) = n * 2 + 2
  Next n
  D3DIndexBuffer8SetData iBuf, 0, 3 * 128 * Len(Ind(0)), 0, Ind(0)
  Set iBuf = Nothing
End Sub
 
Private Sub InitMatrix()
Dim Mtrx As D3DMATRIX
  D3DXMatrixIdentity Mtrx
  d3dDevice.SetTransform D3DTS_WORLD, Mtrx
 
  D3DXMatrixPerspectiveFovLH Mtrx, Pi / 4, frmD3D.ScaleHeight / frmD3D.ScaleWidth, 0.1, 100
  d3dDevice.SetTransform D3DTS_PROJECTION, Mtrx
End Sub
 
Private Sub ClearAll()
  Set Mesh = Nothing
  Set Tex0 = Nothing
  Set Tex1 = Nothing
  D3DTerminate
End Sub
4
Вложения
Тип файла: zip 1.zip (397.7 Кб, 102 просмотров)
Тип файла: zip 2.zip (21.3 Кб, 73 просмотров)
Тип файла: zip 3.zip (432.6 Кб, 88 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
15925 / 6740 / 816
Регистрация: 25.12.2011
Сообщений: 10,442
Записей в блоге: 16
23.02.2013, 17:24  [ТС] #35
Работа с .INI файлами
VBScript (подправил для VB6)

Автор: Keith Lacelle
Правки: Denis St-Pierre, Johan Pol, Rob van der Woude

ReadIni
Visual Basic
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
Function ReadIni( myFilePath, mySection, myKey )
     ' This function returns a value read from an INI file
     '
     ' Arguments:
     ' myFilePath  [string]  the (path and) file name of the INI file
     ' mySection   [string]  the section in the INI file to be searched
     ' myKey       [string]  the key whose value is to be returned
     '
     ' Returns:
     ' the [string] value for the specified key in the specified section
     '
     ' CAVEAT:     Will return a space if key exists but value is blank
     '
     ' Written by Keith Lacelle
     ' Modified by Denis St-Pierre and Rob van der Woude
 
     Const ForReading   = 1
     Const ForWriting   = 2
     Const ForAppending = 8
 
     Dim intEqualPos
     Dim objFSO, objIniFile
     Dim strFilePath, strKey, strLeftString, strLine, strSection
 
     Set objFSO = CreateObject( "Scripting.FileSystemObject" )
 
     ReadIni     = ""
     strFilePath = Trim( myFilePath )
     strSection  = Trim( mySection )
     strKey      = Trim( myKey )
 
     If objFSO.FileExists( strFilePath ) Then
         Set objIniFile = objFSO.OpenTextFile( strFilePath, ForReading, False )
         Do While objIniFile.AtEndOfStream = False
             strLine = Trim( objIniFile.ReadLine )
 
             ' Check if section is found in the current line
             If LCase( strLine ) = "[" & LCase( strSection ) & "]" Then
                 strLine = Trim( objIniFile.ReadLine )
 
                 ' Parse lines until the next section is reached
                 Do While Left( strLine, 1 ) <> "["
                     ' Find position of equal sign in the line
                     intEqualPos = InStr( 1, strLine, "=", 1 )
                     If intEqualPos > 0 Then
                         strLeftString = Trim( Left( strLine, intEqualPos - 1 ) )
                         ' Check if item is found in the current line
                         If LCase( strLeftString ) = LCase( strKey ) Then
                             ReadIni = Trim( Mid( strLine, intEqualPos + 1 ) )
                             ' In case the item exists but value is blank
                             If ReadIni = "" Then
                                 ReadIni = " "
                             End If
                             ' Abort loop when item is found
                             Exit Do
                         End If
                     End If
 
                     ' Abort if the end of the INI file is reached
                     If objIniFile.AtEndOfStream Then Exit Do
 
                     ' Continue with next line
                     strLine = Trim( objIniFile.ReadLine )
                 Loop
             Exit Do
             End If
         Loop
         objIniFile.Close
     Else
         msgbox strFilePath & " doesn't exists. Exiting..."
         exit function
     End If
 End Function


WriteIni
Visual Basic
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
Sub WriteIni( myFilePath, mySection, myKey, myValue )
     ' This subroutine writes a value to an INI file
     '
     ' Arguments:
     ' myFilePath  [string]  the (path and) file name of the INI file
     ' mySection   [string]  the section in the INI file to be searched
     ' myKey       [string]  the key whose value is to be written
     ' myValue     [string]  the value to be written (myKey will be
     '                       deleted if myValue is <DELETE_THIS_VALUE>)
     '
     ' Returns:
     ' N/A
     '
     ' CAVEAT:     WriteIni function needs ReadIni function to run
     '
     ' Written by Keith Lacelle
     ' Modified by Denis St-Pierre, Johan Pol and Rob van der Woude
 
     Const ForReading   = 1
     Const ForWriting   = 2
     Const ForAppending = 8
 
     Dim blnInSection, blnKeyExists, blnSectionExists, blnWritten
     Dim intEqualPos
     Dim objFSO, objNewIni, objOrgIni, wshShell
     Dim strFilePath, strFolderPath, strKey, strLeftString
     Dim strLine, strSection, strTempDir, strTempFile, strValue
 
     strFilePath = Trim( myFilePath )
     strSection  = Trim( mySection )
     strKey      = Trim( myKey )
     strValue    = Trim( myValue )
 
     Set objFSO   = CreateObject( "Scripting.FileSystemObject" )
     Set wshShell = CreateObject( "WScript.Shell" )
 
     strTempDir  = wshShell.ExpandEnvironmentStrings( "%TEMP%" )
     strTempFile = objFSO.BuildPath( strTempDir, objFSO.GetTempName )
 
     Set objOrgIni = objFSO.OpenTextFile( strFilePath, ForReading, True )
     Set objNewIni = objFSO.CreateTextFile( strTempFile, False, False )
 
     blnInSection     = False
     blnSectionExists = False
     ' Check if the specified key already exists
     blnKeyExists     = ( ReadIni( strFilePath, strSection, strKey ) <> "" )
     blnWritten       = False
 
     ' Check if path to INI file exists, quit if not
     strFolderPath = Mid( strFilePath, 1, InStrRev( strFilePath, "\" ) )
     If Not objFSO.FolderExists ( strFolderPath ) Then
         msgbox "Error: WriteIni failed, folder path (" _
                    & strFolderPath & ") to ini file " _
                    & strFilePath & " not found!"
         Set objOrgIni = Nothing
         Set objNewIni = Nothing
         Set objFSO    = Nothing
         exit function
     End If
 
     While objOrgIni.AtEndOfStream = False
         strLine = Trim( objOrgIni.ReadLine )
         If blnWritten = False Then
             If LCase( strLine ) = "[" & LCase( strSection ) & "]" Then
                 blnSectionExists = True
                 blnInSection = True
             ElseIf InStr( strLine, "[" ) = 1 Then
                 blnInSection = False
             End If
         End If
 
         If blnInSection Then
             If blnKeyExists Then
                 intEqualPos = InStr( 1, strLine, "=", vbTextCompare )
                 If intEqualPos > 0 Then
                     strLeftString = Trim( Left( strLine, intEqualPos - 1 ) )
                     If LCase( strLeftString ) = LCase( strKey ) Then
                         ' Only write the key if the value isn't empty
                         ' Modification by Johan Pol
                         If strValue <> "<DELETE_THIS_VALUE>" Then
                             objNewIni.WriteLine strKey & "=" & strValue
                         End If
                         blnWritten   = True
                         blnInSection = False
                     End If
                 End If
                 If Not blnWritten Then
                     objNewIni.WriteLine strLine
                 End If
             Else
                 objNewIni.WriteLine strLine
                     ' Only write the key if the value isn't empty
                     ' Modification by Johan Pol
                     If strValue <> "<DELETE_THIS_VALUE>" Then
                         objNewIni.WriteLine strKey & "=" & strValue
                     End If
                 blnWritten   = True
                 blnInSection = False
             End If
         Else
             objNewIni.WriteLine strLine
         End If
     Wend
 
     If blnSectionExists = False Then ' section doesn't exist
         objNewIni.WriteLine
         objNewIni.WriteLine "[" & strSection & "]"
             ' Only write the key if the value isn't empty
             ' Modification by Johan Pol
             If strValue <> "<DELETE_THIS_VALUE>" Then
                 objNewIni.WriteLine strKey & "=" & strValue
             End If
     End If
 
     objOrgIni.Close
     objNewIni.Close
 
     ' Delete old INI file
     objFSO.DeleteFile strFilePath, True
     ' Rename new INI file
     objFSO.MoveFile strTempFile, strFilePath
 
     Set objOrgIni = Nothing
     Set objNewIni = Nothing
     Set objFSO    = Nothing
     Set wshShell  = Nothing
 End Sub


Использование:
Visual Basic
1
2
3
4
5
WriteIni "C:\test.ini", "TEST1", "My1stKey", "My1stValue"
WriteIni "C:\test.ini", "TEST2", "My1stKey", "My1stValue"
msgbox ReadIni( "C:\test.ini", "TEST1", "My1stKey" )
WriteIni "C:\test.ini", "TEST1", "My1stKey", "My2ndValue"
msgbox ReadIni( "C:\test.ini", "TEST1", "My1stKey" )
Чтобы удалить ключ, нужно ввести значение <DELETE_THIS_VALUE>:
Visual Basic
WriteIni "C:\test.ini", "TEST1", "My1stKey", "<DELETE_THIS_VALUE>"
0
dev.Free
Заблокирован
24.02.2013, 19:08 #36
Работа с .INI файлами:

Код модуля:

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" _
        (ByVal lpapplicationname As String, ByVal lpkeyname As Any, ByVal lpdefault As String, _
        ByVal lpreturnedstring As String, ByVal nSize As Long, ByVal lpfilename As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" _
        (ByVal lpapplicationname As Any, ByVal lpkeyname As Any, _
        ByVal lpstring As Any, ByVal lpfilename As String) As Long
Public Sub writeINI(sINIFile As String, sSection As String, sKey As String, sValue As String)
    Dim n As Integer
    Dim sTemp  As String
    sTemp = sValue
    For n = 1 To Len(sValue)
        If Mid$(sValue, n, 1) = vbCr Or Mid$(sValue, n, 1) = vbLf Then Mid$(sValue, n) = " "
    Next n
    n = WritePrivateProfileString(sSection, sKey, sTemp, sINIFile)
End Sub
Public Function sGetINI(sINIFile As String, sSection As String, sKey As String, sdefault As String)
    Dim sTemp  As String * 256
    Dim nLength As Integer
    sTemp = Space$(256)
    nLength = GetPrivateProfileString(sSection, sKey, sdefault, sTemp, 255, sINIFile)
    sGetINI = Left$(sTemp, nLength)
End Function


Код формы:

Кликните здесь для просмотра всего текста
Visual Basic
1
2
3
4
5
6
7
Private Sub cmdGet_Click()
txtValue = sGetINI(App.Path & "\test.ini", "TestSection", "TestKey", "None")
End Sub
 
Private Sub cmdWrite_Click()
writeINI App.Path & "\test.ini", "TestSection", "TestKey", txtValue
End Sub
2
Pro_grammer
Модератор
5933 / 2094 / 401
Регистрация: 24.04.2011
Сообщений: 3,569
Записей в блоге: 10
12.03.2013, 07:22 #37
Великолепная по качеству 3D игра, сделанная по фильму ТРОН.

Автор кода на VB6 - Матиас Кантер (Mathias Kunter).

REVO TRON v 1.4
http://revotron.tripod.com
Copyright by Mathias Kunter. Mail: mathiaskunter@yahoo.de

*************************LEGAL STUFF*************************
REVO TRON is copyrighted by Mathias Kunter, but it's freeware and
open source. This means you're free to copy and edit the game and give
it to other people. You use this game at your own risk, and the game
programmer isn't responsible for any damages on software or hardware
which may occur when playing REVO TRON.
When starting REVO TRON, you agree to these conditions automatically.


Оф. сайт: http://revotron.tripod.com
5
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip 3DTron.zip (789.7 Кб, 225 просмотров)
Апострофф
Заблокирован
19.04.2013, 10:50 #38
Текст для теста оформляется по элементарным правилам (достаточно найти и открыть скрытый файл Test.txt в приложенной папке)
Код
Visual Basic
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
Option Explicit
 
Sub main()
Dim s As String
Dim a
Dim v
Dim n() As Long
Dim i As Long, j As Long, k As Long
Dim b() As Long
Dim p As Long
Open App.Path & "\Test.txt" For Input As 1
  s = Input$(LOF(1), 1)
Close
a = Split(s, vbCrLf & vbCrLf)
ReDim n(UBound(a))
Randomize
For i = 0 To UBound(n)
  j = Int(Rnd * (i + 1))
  n(i) = n(j)
  n(j) = i
Next i
For i = 0 To UBound(n)
  v = Split(a(n(i)), vbCrLf)
  s = v(0)
  ReDim b(1 To UBound(v))
  For k = 1 To UBound(b)
    j = Int(Rnd * k + 1)
    b(k) = b(j)
    b(j) = k
  Next k
  For k = 1 To UBound(b)
    s = s & vbCrLf & vbCrLf & k & ":  " & v(b(k))
  Next k
  Do
    j = Val(InputBox(s, "Введите номер правильного ответа"))
    If j < 1 Or j > UBound(b) Then
      If MsgBox("Повторить - [Да]" & vbCrLf & "Выйти - [Нет]", vbYesNo, "Не корректный ввод!") <> vbYes Then Exit Sub
    Else
      Exit Do
    End If
  Loop
  p = p - (b(j) = 1)
Next i
MsgBox "Вы дали " & p & " правильных ответов из " & i
End Sub
3
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: zip test.zip (2.9 Кб, 154 просмотров)
The trick
Модератор
7193 / 2425 / 741
Регистрация: 22.02.2013
Сообщений: 3,476
Записей в блоге: 74
23.04.2013, 21:55 #39
Тест с закодированными вопросами и ответами, с защитой от неправильного изменения.
5
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar TrickTest.rar (43.6 Кб, 250 просмотров)
Dragokas
Эксперт WindowsАвтор FAQ
15925 / 6740 / 816
Регистрация: 25.12.2011
Сообщений: 10,442
Записей в блоге: 16
24.09.2013, 00:08  [ТС] #40
Обновленный API Viewer

http://www.activevb.de/rubriken/apiv...g.html#anchor2
2
SoftIce
10017 / 3550 / 906
Регистрация: 27.07.2011
Сообщений: 8,443
Завершенные тесты: 1
24.09.2013, 07:25 #41
Цитата Сообщение от Dragokas Посмотреть сообщение
Обновленный API Viewer

Не по теме:

У некоторых и необновленного нет


Выкладываю два "старых".
4
Вложения
Тип файла: rar Winapi.rar (196.6 Кб, 109 просмотров)
Тип файла: rar WINAPITOOLS( С исходником) .rar (696.8 Кб, 108 просмотров)
JoraVoenyjHaker
Заблокирован
17.10.2013, 07:53 #42
Перекодирование текста стандартными средствами Windows
Сохранение и загрузка списка
Запись байт в файл (Возврат: Следующая позиция записи (при успешном выполнении)
Чтение байт из файла (Возврат: Массив байт)

Вот мой готовый модуль для удовлетворения почти всех потребностей в работе с файлами
работает в обычном модуле .Bas
но вы можете установить в своём классе, или объекте

Код обсуждается в теме: Файловые операции

Visual Basic
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
Option Explicit
DefLng F, H-I, L, N, U: DefDbl D, M: DefStr J, S: DefBool B: DefObj O: DefVar V
'
'                   Модуль для работы с файлами и сохранением списков
'                   ©JoraVoenyjHaker
'
'--------------------------[Константы]
Private Const MaxSpace = 256
Public Enum F_ReCod
    [Без изменений] = 0
    [Windows To DOS] = 1
    [DOS To Windows] = 2
    [Binary To Unicode] = 4
    [Unicode To Binary] = 8
    [Без нулей справа] = 16
    [Без нулей слева] = 32
End Enum
'--------------------------[Переменные модуля]
Dim FxSpace As String * MaxSpace, Byt() As Byte
Dim f, n, n1, Dln, AnyString$, i, Dln1&
'--------------------------[Api Функции]
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
 
Public Function LoadList(Path$) As String()
    'Загрузка списка
    Dim f, f1, ul, n, n1, i, j(), text$
    text = ReadBytes(Path, [Binary To Unicode])
 
    For f = 1 To 3
        n = n * 256 + Asc(Mid$(text, f, 1))
    Next
    ul = Fix(n) / 3: n = n Mod 3
    ReDim j(ul)
    On Error GoTo 10
 
    For f = 4 To ul * (n + 1) + 4 Step n + 1
        n1 = 0
 
        For f1 = f To f + n
            n1 = n1 * 256 + Asc(Mid$(text, f1, 1))
        Next
        j(i) = n1: i = i + 1
    Next
 
    For f1 = 0 To ul
        n = j(f1)
        j(f1) = Mid$(text, f, n)
        f = f + n
    Next
10
    LoadList = j
End Function
 
Public Sub SaveList(Path$, List$())
    'Сохранение списка
    Dim f, f1, ul, n, j()
    ul = UBound(List)
    '-------------
    ReDim Preserve j(ul + 1)
 
    For f = 1 To ul + 1
        n = Len(List(f - 1))
        j(f) = Space(3)
 
        For f1 = 3 To 1 Step -1
            Mid$(j(f), f1, 1) = Chr(n Mod 256)
            n = Fix(n / 256)
        Next
    Next
    '----------------------- Сжать индексы
    For f = 2 To 0 Step -1
 
        For f1 = 1 To ul + 1
            If Mid$(j(f1), 1, 1) <> vbNullChar Then GoTo 10
        Next
 
        For f1 = 1 To ul + 1
            j(f1) = Mid$(j(f1), 2)
        Next
    Next
10
    '------------------ Первая ячейка
    n = ul * 3 + Abs(f)
    j(0) = Space(3)
 
    For f = 3 To 1 Step -1
        Mid$(j(0), f, 1) = Chr(n Mod 256)
        n = Fix(n / 256)
    Next
    Call WriteBytes(Path, Join(j, "") & Join(List, ""), [Unicode To Binary], 1, True)
End Sub
 
Public Function WriteBytes&(Path$, Bytes As Variant, Optional ByVal Flag As F_ReCod, Optional ByVal Start& = 1, Optional Overwrite As Boolean)
    'Запись байт в файл
    'Арг: Путь // Массив байт (Или текст) // Флаг кодировки // Старт // Флаг перезаписи
    'Возврат: Следующая позиция записи (при успешном выполнении)
    On Error GoTo 1
    If Overwrite Then Call Kill(Path)
1
    Open Path For Binary As #1
    Byt = Bytes
    If Start Then Else Start = 1
    Put #1, Start, ReCod(Byt, Flag)
    WriteBytes = Start + UBound(Byt) + 1
    Close #1
End Function
 
Public Function ReadBytes(Path$, Optional ByVal Flag As F_ReCod, Optional ByVal Start&, Optional ByVal Dln&) As Byte()
    'Чтение байт из файла
    'Арг: Путь // Флаг кодировки // Старт // Длина
    'Возврат: Массив байт
    Open Path For Binary As #1
    On Error Resume Next
    If Start Then Else Start = 1
    Dln1 = LOF(1) - Start + 1
    If Dln = 0 Or Dln > Dln1 Then Dln = Dln1
    ReDim Preserve ReadBytes(Dln - 1)
    Get #1, Start, ReadBytes
    ReadBytes = ReCod(ReadBytes, Flag)
    Close #1
End Function
 
Public Function ReCod(Bytes As Variant, Optional ByVal Flag As F_ReCod) As Byte()
    'Перекодирование текста стандартами Windows
    'Bytes: Массив байт (Или текст)
    'Flag: Комбинируемые команды: [DOS to Windows] + [Binary to Unicode] ...
    ReCod = Bytes
 
    While Flag > 0
 
        Select Case Flag
        Case Is >= [Без нулей слева]
            Flag = Flag - [Без нулей слева]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = Mid$(ReCod, f)
        Case Is >= [Без нулей справа]
            '-------------------------
            ReCod = StrReverse(ReCod)
            Flag = Flag - [Без нулей справа]
            n = MaxSpace
            f = 1
 
            Do While n > 0
 
                For f = f To UBound(ReCod) + 1 Step n
                    If Mid$(ReCod, f, n) <> Mid$(FxSpace, 1, n) Then Exit For
                Next
                n = n / 2
            Loop
            ReCod = StrReverse(Mid$(ReCod, f))
            '-----------------------------------------------
        Case Is >= [Unicode To Binary]
            Flag = Flag - [Unicode To Binary]
            ReCod = StrConv(ReCod, vbFromUnicode)
        Case Is >= [Binary To Unicode]
            Flag = Flag - [Binary To Unicode]
            ReCod = StrConv(ReCod, vbUnicode)
        Case Is >= [DOS To Windows]
            Flag = Flag - [DOS To Windows]
            AnyString = ReCod
            Call OemToChar(ReCod, AnyString)
            ReCod = AnyString
        Case Is >= [Windows To DOS]
            Flag = Flag - [Windows To DOS]
            AnyString = ReCod
            Call CharToOem(ReCod, AnyString)
            ReCod = AnyString
        End Select
    Wend
End Function
0
zink0000
188 / 65 / 24
Регистрация: 15.03.2012
Сообщений: 265
Записей в блоге: 15
17.10.2013, 10:09 #43
Перекодировка текстовых файлов из ANSI в Unicode UTF-8

Программа позволяет конвертировать текстовые файлы в заданном каталоге (со всеми вложенными подкаталогами)
из кодировки ANSI в Unicode UTF-8, копируя файлы в каталог-результат.
win2utf8.zip
Может пригодится кому.


Внимание! При назначении папки для результатов обратите внимание на сообщение "ВСЕ файлы и ВСЕ папки в этом каталоге будут УДАЛЕНЫ!" Не назначайте в качестве каталога-результата каталог с ценной для Вас информацией!
0
JoraVoenyjHaker
Заблокирован
19.10.2013, 01:11 #44
StyleCreator
Новая моя программа для создания нормального Windows стиля на вашей форме (с прозрачностью)
необходимо запустить, указать или создать папку проекта, и нажать кнопку
после чего будет создан стандартный проект со всеми настройками

Да вот ещё что, нормальная работа может быть гарантирована
если установлен VB6

скриншот к StyleCreator
2
Миниатюры
Готовые решения и полезные коды на Visual Basic 6.0  
Вложения
Тип файла: rar StyleCreator.rar (175.6 Кб, 135 просмотров)
JoraVoenyjHaker
Заблокирован
24.10.2013, 14:29 #45
Очередное моё решение по транслитерации текста
ниже преведен готовый алгоритм


тема обсуждается в Замена кириллицы на транслит

Модуль Form1:
Visual Basic
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
Option Explicit
'
'       Алгоритм быстрой транслитирации
'       работает на Form1 контроле Text1
'       rezj - Текущее значение по умолчанию "РЕЖИМ ENG"
'       © JoraVoenyjHaker
'
Private dicReplace As Object
Private bsi As Object
Private rezj$
 
Private Sub Form_Initialize()
    Text1.Text = " "
    Const r = "/"
    Dim jr$(), je$(), jb$(), f&
    Dim rus$, eng$, bsini$
    rezj = "РЕЖИМ ENG" 'По умолчанию включен "РЕЖИМ ENG"  
    ''rezj = "РЕЖИМ RUS"
    rus = "а/б/в/г/д/е/ё/ж/з/и/й/к/л/м/н/о/п/р/с/т/у/ф/х/ц/ч/ш/щ/ъ/ы/ь/э/ю/я"
    eng = "a/b/v/g/d/e/yo/j/z/i/i`/k/l/m/n/o/p/r/s/t/u/f/h/c/ch/sh/s`/``/y`/`/e`/iu/ia"
    bsini = "yo/i`/ch/sh/``/y`/e`/iu/ia"
    jr = Split(rus, r): je = Split(eng, r): jb = Split(bsini, r)
    Set dicReplace = CreateObject("Scripting.Dictionary") '-----Запись сопоставлений для замены
    With dicReplace
        For f = 0 To UBound(jr): .Add jr(f), je(f): Next
        For f = 0 To UBound(je): .Add je(f), jr(f): Next
    End With
    Set bsi = CreateObject("Scripting.Dictionary")   '-----Запись сопоставлений для удаления
    With bsi
        For f = 0 To UBound(jb): .Add jb(f), "True": Next
    End With
End Sub
 
Private Sub Text1_KeyPress(KeyAscii As Integer)
    Static b As Boolean, key$, old$
    On Error Resume Next
    Select Case KeyAscii
    Case 32 'Ничего не происходит
    Case 8
        If rezj = "РЕЖИМ ENG" Then
            If bsi.Item(Mid$(Text1, Text1.SelStart - 1, 2)) Then
                If Not b Then b = True: SendKeys "{BS}", True
            End If
        End If
    Case Else
        'Здесь описание для замены английских
        If rezj = "РЕЖИМ ENG" Then
            key = Mid$(Text1, Text1.SelStart, 1) & Chr(KeyAscii)
            If Len(dicReplace.Item(key)) > 0 Then
                If Not b Then
                    b = True
                    SendKeys "{BS}", True
                    Text1.SelText = dicReplace.Item(key)
                    KeyAscii = 0
                End If
            Else
                key = Chr(KeyAscii)
                If Not b Then
                    b = True
                    Text1.SelText = dicReplace.Item(key)
                    KeyAscii = 0
                End If
            End If
            
        ElseIf rezj = "РЕЖИМ RUS" Then
            key = Chr(KeyAscii)
            old = old & key
            If Len(old) > 1 And Not b And dicReplace.Item(old) <> "" Then
                b = True: SendKeys "{BS}", True
                Text1.SelText = dicReplace.Item(old)
                KeyAscii = 0
            Else
                Text1.SelText = dicReplace.Item(key)
                KeyAscii = 0
            End If
            If Len(old) > 1 Then old = Mid(old, 2)
        End If
    End Select
    b = False
End Sub

После запуска напишите слово на русском, в русской раскладке
2
MoreAnswers
Эксперт
37091 / 29110 / 5898
Регистрация: 17.06.2006
Сообщений: 43,301
24.10.2013, 14:29
Привет! Вот еще темы с ответами:

Visual Basic 6 и Visual Basic .NET - в чем различия? - Visual Basic
Visual Basic и Visual studio это не одно и тоже? если нет то в чём разница, по мимо оформления?

Отличия версий Visual Basic 6.0 от Visual Basic 6.5? - Visual Basic
У меня 3 вопроса: 1.Чем отличается версия Visual Basic 6.0 от Visual Basic 6.5? 2.Можно ли запустить проект созданный раннее в Visual...

Кто пишет программы в Visual Studio 2010 на Visual Basic? - Visual Basic
Кто пишет программы в Visual Studio 2010 на Visual Basic?

Проблема с установкой Visual Studio вообще и Visual Basic - Visual Basic
Точнее, с установкой Visual Studio вообще и Visual Basic в частности. В самом конце установки, при setup is updating your system,...


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

Или воспользуйтесь поиском по форуму:
Yandex
Объявления
24.10.2013, 14:29
Ответ Создать тему
Опции темы

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