purebasic.info

PureBasic forum
Текущее время: Вт янв 16, 2018 8:41 pm

Часовой пояс: UTC + 3 часа




Начать новую тему Ответить на тему  [ Сообщений: 37 ]  На страницу 1, 2, 3  След.
Автор Сообщение
 Заголовок сообщения: Полезные советы.
СообщениеДобавлено: Чт сен 01, 2011 6:59 pm 
Не в сети
МОДЕРАТОР
Аватар пользователя

Зарегистрирован: Пн апр 09, 2007 4:53 pm
Сообщений: 11077
Благодарил (а): 4 раз.
Поблагодарили: 384 раз.
Предлагаю здесь публиковать различные советы, связанные с программированием на пурике.

_________________
Компьютер позволяет решать все те проблемы, которые до его изобретения не существовали. :) :)


Последний раз редактировалось Пётр Чт сен 01, 2011 7:07 pm, всего редактировалось 1 раз.

Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Чт сен 01, 2011 7:04 pm 
Не в сети
МОДЕРАТОР
Аватар пользователя

Зарегистрирован: Пн апр 09, 2007 4:53 pm
Сообщений: 11077
Благодарил (а): 4 раз.
Поблагодарили: 384 раз.
Если вы собираетесь копировать структуру с помощью функции CopyStructure(), то предварительно очистите структуру, в которую будет осуществятся копирование, иначе программа может вылетать с ошибкой доступа к памяти или выхода за границы переменной (если Purifier включен).
Очистить структуру можно функцией ClearStructure().

_________________
Компьютер позволяет решать все те проблемы, которые до его изобретения не существовали. :) :)


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Чт сен 01, 2011 7:27 pm 
Не в сети
профессор
Аватар пользователя

Зарегистрирован: Вт май 24, 2011 7:01 pm
Сообщений: 505
Благодарил (а): 0 раз.
Поблагодарили: 2 раз.
Пункты репутации: 0
Спасибо Петр за совет. Признаться я и не знал о этих функциях, все делал через функциями для работы с памятью.


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Чт сен 01, 2011 7:33 pm 
Не в сети
МОДЕРАТОР
Аватар пользователя

Зарегистрирован: Пн апр 09, 2007 4:53 pm
Сообщений: 11077
Благодарил (а): 4 раз.
Поблагодарили: 384 раз.
Димастый писал(а):
Признаться я и не знал о этих функциях
Еще есть функции CopyArray() и CopyList(), предназначенные для копирования массивов и списков соответственно.

_________________
Компьютер позволяет решать все те проблемы, которые до его изобретения не существовали. :) :)


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Вс сен 04, 2011 1:31 am 
Не в сети
док

Зарегистрирован: Вт июл 17, 2007 1:34 pm
Сообщений: 90
Откуда: Пенза
Благодарил (а): 0 раз.
Поблагодарили: 0 раз.
Пункты репутации: 0
Для удобства чтения кода, а в некоторых случаях и его упрощения у программ , использующих работу с памятью и указателями рекомендую использовать типизированные указатели.
Пример 1:
Вместо value.l = PeekL(*MemoryAdress)
можно использовать типизированный указатель *value.LONG
При изменении значения переменной *value меняется адрес, на который ссылается значение поля l структуры LONG переменной *value.
В итоге у нас получится *value.LONG = *MemoryAdress,
а обращение ко значению через поле *value\l

Пример 2:
Дан буфер памяти *buffer размера кратного 8-ми байт, представляющий собой цепочку 8-ми байтных значений. Нужно поменять старшие и младшие двойные слова местами у каждого 8-ми байтного значения
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Dim Nums.q(100)
For i = 0 To 99
  Nums(i) = Random(999999)
Next
;
Structure LONG_2
  first.l
  second.l
EndStructure
;
*buffer.LONG_2 = @Nums()
*limit = *buffer + 100 * SizeOf(QUAD)
While *buffer < *limit
  Swap *buffer\first, *buffer\second
  *buffer + SizeOf(QUAD)
Wend
 


_________________
purebasic x64


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Пт сен 23, 2011 4:21 pm 
Не в сети
профессор
Аватар пользователя

Зарегистрирован: Вт май 24, 2011 7:01 pm
Сообщений: 505
Благодарил (а): 0 раз.
Поблагодарили: 2 раз.
Пункты репутации: 0
В заголовочных файлах (инклуды.pbi) использую такую связку макросов:
Код:
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
Macro Quote
  "
EndMacro
 
Macro ErrorImport(Funct)
 MessageRequester("Error:", "Error import function: " + Quote#Funct#Quote+#CR$+"Line: " +Str(#PB_Compiler_Line), #MB_OK|#MB_ICONERROR)
EndMacro
 
Macro _Import_(Funct,Args,Lib)
 Prototype Funct#Args
 Global Funct.Funct = GetFunction(Lib,Quote#Funct#Quote)
 If Funct  = 0
  ErrorImport(Funct)
 EndIf
EndMacro
 
Macro _U_Import_(Funct,Args,Lib)
Prototype Funct#Args
CompilerIf #PB_Compiler_Unicode
 Global Funct.Funct = GetFunction(Lib,Quote#Funct#W#Quote)
CompilerElse
 Global Funct.Funct = GetFunction(Lib,Quote#Funct#A#Quote)
CompilerEndIf
If Funct  = 0
  ErrorImport(Funct)
EndIf
EndMacro
;Kernel32 = OpenLibrary(#PB_Any,"Kernel32.dll")
_Import_(Beep,(a, b),kernel32)
 
_U_Import_(DefineDosDevice,(dwFlags.l,lpDeviceName, lpTargetPath),kernel32)


Особенно полезно когда прототипируется много функций, например если описывать библиотеку kernel32.dll.


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Вс сен 25, 2011 4:19 pm 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
Иногда возникает необходимость вывести MessageBox с информацией, и хотелось бы воткнуть в него свою иконку, но MessageBox позволяет лишь 5 вариантов - нет иконки, стоп, внимание и т.д.
Можно исправить эту ситуацию применив win api функцию MessageBoxIndirect
Создаем файл ресурсов rsrc.rc (можно просто в Блокноте) с таким содержанием
100 ICON DISCARDABLE "C:\Program Files\PureBasic\MyPrograms/myico.ico"
включаем его в проект (свойства проекта, вкладка Resourses)
Дальше пишем функцию (я назвал ее по старинке MsgBox)
где header - заголовок месаги, body - содержание, ico - номер ресурса в файле rsrc.rc
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Procedure MsgBox(header.s, body.s, ico.l)
    #MB_USERICON = $080
    Message.s = body
    Caption.s   = header
    mbox.MSGBOXPARAMS
    mBox\cbSize = SizeOf(MSGBOXPARAMS)
    mbox\hwndOwner = WindowID(#Main)        ; если поставить 0, это окно отобразится на панели задач
    mbox\hInstance = GetModuleHandle_(0)
    mbox\lpszText = @Message
    mbox\lpszCaption = @Caption
    mbox\dwStyle = #MB_OK | #MB_USERICON
    mbox\lpszIcon = ico          
    mbox\dwContextHelpId = 0
    mbox\lpfnMsgBoxCallback = 0
    mbox\dwLanguageId = 0
    MessageBoxIndirect_(mbox)
EndProcedure


Ну и вызываем эту функцию с нужными параметрами

_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Последний раз редактировалось pablov Вс сен 25, 2011 5:14 pm, всего редактировалось 1 раз.

Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Вс сен 25, 2011 5:05 pm 
Не в сети
профессор
Аватар пользователя

Зарегистрирован: Пн сен 07, 2009 10:00 pm
Сообщений: 1046
Откуда: Николаев
Благодарил (а): 0 раз.
Поблагодарили: 0 раз.
Пункты репутации: 0
100 ICON DISCARDABLE "C:\Program Files\PureBasic\MyPrograms/myico.ico"

_________________
www.mirashic.narod.ru
Первое знакомство с PB


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Вс сен 25, 2011 5:12 pm 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
mirashic спасибо за поправку

_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Чт окт 20, 2011 7:35 am 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
В PB есть функция ReverseString(String$) - разворачивает строку посимвольно.
У меня возникла ситуация, когда строка это последовательность байт и ее надо развернуть побайтно. Вот что получилось
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
Procedure$ ReverseStringByte(String$)        ; Разворот строки по байтам
   Protected byte.s,i.w
   Protected Length = Len(String$)
   For i = 1 To Length/2
     byte = Mid(String$, 1, 2)
     String$ = InsertString(Right(String$, Length-2), byte, Length-i-n)
     n + 1
   Next
  ProcedureReturn String$
EndProcedure
 
Debug ReverseStringByte("46ADFF12E0")
 


_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Пн фев 27, 2012 2:02 pm 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
Конвертер байт > килобайты > мегабайты и т.д.
Код:
1
2
3
4
5
6
7
8
9
10
11
12
13
Procedure.s Convert(filesize.d, n.w)   ; n - количество знаков после запятой
level.b = 0
Dim units.s(4)
units(0) = "Б" : units(1) = "КБ" : units(2) = "МБ" : units(3) = "ГБ" : units(4) = "ТБ"
While filesize > 1023
    filesize = filesize / 1024
    level + 1
Wend
If level = 0 : n = 0 : EndIf  
  ProcedureReturn StrD(filesize, n) + " " + units(level)
EndProcedure
 
Debug Convert(812729, 2)


_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Чт мар 01, 2012 8:46 pm 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
Удаление иконки программы из трея (программа продолжает работать)
Код:
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
;OS windows XP only
;==================
Prototype.l PFNGETMODULEFILENAMEEXA(hProcess.l,  hModule.l, lpFilename.l, nSize.l)
               
;tbHwnd - хэндл тулбара трея
;iCnt - количество иконок в трее (возвращается по сообщению #TB_BUTTONCOUNT тулбару)
;exeName - имя исполняемого модуля, иконку которого нужно убрать
Procedure DeleteIconByAppName(tbHwnd, iCnt, exeName.s)
        hAppWnd.l
        hProc.l
        hApp.l
        btninfo.TBBUTTON
  tb.l
        pID.l
  readed.l = 0
  result.b = #False
  buffer.s{#MAX_PATH}
  Protected GetModuleFileName.PFNGETMODULEFILENAMEEXA
  If OpenLibrary(0,"PSAPI.DLL")
    GetModuleFileName = GetFunction(0, "GetModuleFileNameExA")
  Else
    MessageRequester("Ошибка", "Не могу открыть библиотеку 'PSAPI.DLL'", #MB_OK|#MB_ICONERROR)
    End
  EndIf    
        GetWindowThreadProcessId_(tbHwnd, @pID);
          hProc = OpenProcess_(#PROCESS_VM_OPERATION|#PROCESS_VM_READ, #False, pID)
        If hProc <> #INVALID_HANDLE_VALUE
          tb = VirtualAllocEx_(hProc, 0, SizeOf(TBBUTTON), #MEM_COMMIT, #PAGE_READWRITE)
           If tb
                        For c = 0 To  iCnt - 1
                                SendMessage_(tbHwnd, #TB_GETBUTTON, c, tb)
                                ReadProcessMemory_(hProc, tb, @btninfo, SizeOf(TBBUTTON), @readed)
                                If readed < SizeOf(TBBUTTON) : Break : EndIf
                                ReadProcessMemory_(hProc, btninfo\dwData, @hAppWnd, SizeOf(LONG), @readed)
                                If readed < SizeOf(LONG) : Break : EndIf
                                GetWindowThreadProcessId_(hAppWnd, @pID)
;                               Debug btninfo\fsState        ; 4 - кнопка отображена ; 8 - отключена; 12 - скрыта
          hApp = OpenProcess_(#PROCESS_QUERY_INFORMATION|#PROCESS_VM_READ , #False, pID)                                                                                       
                                If hApp <> #INVALID_HANDLE_VALUE
                                        If GetModuleFileName(hApp, 0, @buffer, #MAX_PATH)
                                          filename$ = LCase(GetFilePart(buffer))
              If CompareMemoryString(@exeName, @filename$, #PB_String_NoCase) = #PB_String_Equal
                SendMessage_(tbHwnd, #TB_DELETEBUTTON, c, 0)    ; удаляет кнопку!
                                                          CloseHandle_(hApp);
                                                          Break
              EndIf
                                        EndIf
                                        CloseHandle_(hApp)
                                EndIf                  
                        Next c
                          VirtualFreeEx_(hProc, tb, SizeOf(TBBUTTON), #MEM_RELEASE)
                 EndIf
                 CloseHandle_(hProc)
    EndIf
    CloseLibrary(0)
EndProcedure   
 
Procedure main()
        hTool.l
        iconCount.l=0
        exeName.s{#MAX_PATH}
       
  hnd   = FindWindow_("Shell_TrayWnd", #Null)
  hnd   = FindWindowEx_(hnd, #Null, "TrayNotifyWnd", #Null)
  hnd   = FindWindowEx_(hnd, #Null, "SysPager", #Null)
  hTool = FindWindowEx_(hnd, #Null, "ToolbarWindow32", #Null)  
  If hTool
     iconCount = SendMessage_(hTool, #TB_BUTTONCOUNT, 0, 0)
                 If iconCount
                   exeName = LCase(InputRequester("ExeName", "Введите имя  exe-файла  (255 символов max): ", ""))
                         If exeName : DeleteIconByAppName(hTool, iconCount, exeName) : EndIf           
                EndIf
        EndIf
EndProcedure   
 
main()


_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Пн мар 12, 2012 12:21 pm 
Не в сети
МОДЕРАТОР
Аватар пользователя

Зарегистрирован: Пн апр 09, 2007 4:53 pm
Сообщений: 11077
Благодарил (а): 4 раз.
Поблагодарили: 384 раз.
Indy писал(а):
Вы есчо драйвера запретите кодить
Дрова бывают разные.
Большинство из них, все таки полезные.

_________________
Компьютер позволяет решать все те проблемы, которые до его изобретения не существовали. :) :)


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Пн мар 12, 2012 3:36 pm 
Не в сети
профессор

Зарегистрирован: Ср янв 14, 2009 4:12 pm
Сообщений: 2002
Благодарил (а): 12 раз.
Поблагодарили: 101 раз.
Пункты репутации: 43
Пример демонстрирует, как извлечь информацию о первом физическом диске в системе. Работает под администратором
Код:
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
#IOCTL_DISK_GET_DRIVE_GEOMETRY  = $70000
Structure DISK_GEOMETRY
   Cylinders.q
   MediaType.l
   TracksPerCylinder.l
   SectorsPerTrack.l
   BytesPerSector.l
EndStructure
 
Procedure.s Convert(filesize.d, n.w)   ; n - количество знаков после запятой
  level.b = 0
  Dim units.s(4)
  units(0) = "Б" : units(1) = "КБ" : units(2) = "МБ" : units(3) = "ГБ" : units(4) = "ТБ"
  While filesize > 1023
    filesize = filesize / 1024
    level + 1
  Wend
  If level = 0 : n = 0 : EndIf  
  ProcedureReturn StrD(filesize, n) + " " + units(level)
EndProcedure
 
Procedure.s GetMediaType(mt.l)
  MediaType.s = ""
  Select mt
    Case 0
      MediaType = "Format is unknown"
    Case 1
      MediaType = "A 5.25' floppy, with 1.2MB and 512 bytes/sector."
    Case 2
      MediaType = "A 3.5' floppy, with 1.44MB and 512 bytes/sector."
    Case 3
      MediaType = "A 3.5' floppy, with 2.88MB and 512 bytes/sector."
    Case 4
      MediaType = "A 3.5' floppy, with 20.8MB and 512 bytes/sector."
    Case 5
      MediaType = "A 3.5' floppy, with 720KB and 512 bytes/sector."
    Case 6
      MediaType = "A 5.25' floppy, with 360KB and 512 bytes/sector."
    Case 7
      MediaType = "A 5.25' floppy, with 320KB and 512 bytes/sector."
    Case 8
      MediaType = "A 5.25' floppy, with 320KB and 1024 bytes/sector."
    Case 9
      MediaType = "A 5.25' floppy, with 180KB and 512 bytes/sector."
    Case 10
      MediaType = "A 5.25' floppy, with 160KB and 512 bytes/sector."
    Case 11
      MediaType = "Removable media other than floppy."
    Case 12
      MediaType = "Fixed hard disk media."
    Case 13
      MediaType = "A 3.5' floppy, with 120MB and 512 bytes/sector."
    Case 14
      MediaType = "A 3.5' floppy, with 640KB and 512 bytes/sector."
    Case 15
      MediaType = "A 5.25' floppy, with 640KB and 512 bytes/sector."
    Case 16
      MediaType = "A 5.25' floppy, with 720KB and 512 bytes/sector."
    Case 17
      MediaType = "A 3.5' floppy, with 1.2MB and 512 bytes/sector."
    Case 18
      MediaType = "A 3.5' floppy, with 1.23MB and 1024 bytes/sector."
    Case 19
      MediaType = "A 5.25' floppy, with 1.23MB and 1024 bytes/sector."
    Case 20
      MediaType = "A 3.5' floppy, with 128MB and 512 bytes/sector."
    Case 21
      MediaType = "A 3.5' floppy, with 230MB and 512 bytes/sector."
    Case 22
      MediaType = "An 8' floppy, with 256KB and 128 bytes/sector."
    Case 23
      MediaType = "A 3.5' floppy, with 200MB and 512 bytes/sector. (HiFD)."
    Case 24
      MediaType = "A 3.5' floppy, with 240MB and 512 bytes/sector. (HiFD)."
    Case 25
      MediaType = "A 3.5' floppy, with 32MB and 512 bytes/sector."
    Default
      MediaType = "Format is unknown"
  EndSelect
  ProcedureReturn MediaType
EndProcedure
 
Procedure.b GetDriveGeometry()
 
  hDevice.l;               ; дескриптор проверяемого устройства
  junk.l                   ; сбрасываем результаты
  ; открываем устройство (диск C: )
  hDevice = CreateFile_("\\.\\PhysicalDrive0", 0, #FILE_SHARE_READ|#FILE_SHARE_WRITE, #Null, #OPEN_EXISTING, 0, #Null)
 
  If hDevice = #INVALID_HANDLE_VALUE               ; невозможно открыть устройство
      ProcedureReturn #False
  Else
      pdg.DISK_GEOMETRY
      If DeviceIoControl_(hDevice, #IOCTL_DISK_GET_DRIVE_GEOMETRY, #Null, 0, @pdg, SizeOf(pdg), @junk, #Null)
          Debug "Cylinders = " + Str(pdg\Cylinders)
          Debug "Tracks per cylinder = " + Str(pdg\TracksPerCylinder)
          Debug "Sectors per track = " + Str(pdg\SectorsPerTrack)
          Debug "Bytes per sector = " + Str(pdg\BytesPerSector)
          Debug GetMediaType(pdg\MediaType)
          DiskSize.q = pdg\Cylinders * pdg\TracksPerCylinder * pdg\SectorsPerTrack * pdg\BytesPerSector
          Debug Convert(DiskSize, 2)
      Else  
          CloseHandle_(hDevice)
          ProcedureReturn #False
      EndIf  
  EndIf    
  CloseHandle_(hDevice)
 
  ProcedureReturn #True
EndProcedure
 
GetDriveGeometry()


Кстати, это вариант отличить USB HDD от фиксированного HDD
********************************************************
Пример демонстрирует, как извлечь информацию о CD\DVD диске. При использовании вставьте CD\DVD диск.
Код:
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
#IOCTL_DISK_GET_DRIVE_GEOMETRYEX  = $24050
Structure DISK_GEOMETRY
   Cylinders.q
   MediaType.l
   TracksPerCylinder.l
   SectorsPerTrack.l
   BytesPerSector.l
EndStructure
 
Structure DISK_GEOMETRY_EX
  geometry.DISK_GEOMETRY
  DiskSize.q
  byte.b[1];
EndStructure
 
Procedure.s Convert(filesize.d, n.w)   ; n - количество знаков после запятой
  level.b = 0
  Dim units.s(4)
  units(0) = "Б" : units(1) = "КБ" : units(2) = "МБ" : units(3) = "ГБ" : units(4) = "ТБ"
  While filesize > 1023
    filesize = filesize / 1024
    level + 1
  Wend
  If level = 0 : n = 0 : EndIf  
  ProcedureReturn StrD(filesize, n) + " " + units(level)
EndProcedure
 
Procedure.s GetMediaType(mt.l)
  MediaType.s = ""
  Select mt
    Case 0
      MediaType = "Format is unknown"
    Case 1
      MediaType = "A 5.25' floppy, with 1.2MB and 512 bytes/sector."
    Case 2
      MediaType = "A 3.5' floppy, with 1.44MB and 512 bytes/sector."
    Case 3
      MediaType = "A 3.5' floppy, with 2.88MB and 512 bytes/sector."
    Case 4
      MediaType = "A 3.5' floppy, with 20.8MB and 512 bytes/sector."
    Case 5
      MediaType = "A 3.5' floppy, with 720KB and 512 bytes/sector."
    Case 6
      MediaType = "A 5.25' floppy, with 360KB and 512 bytes/sector."
    Case 7
      MediaType = "A 5.25' floppy, with 320KB and 512 bytes/sector."
    Case 8
      MediaType = "A 5.25' floppy, with 320KB and 1024 bytes/sector."
    Case 9
      MediaType = "A 5.25' floppy, with 180KB and 512 bytes/sector."
    Case 10
      MediaType = "A 5.25' floppy, with 160KB and 512 bytes/sector."
    Case 11
      MediaType = "Removable media other than floppy."
    Case 12
      MediaType = "Fixed hard disk media."
    Case 13
      MediaType = "A 3.5' floppy, with 120MB and 512 bytes/sector."
    Case 14
      MediaType = "A 3.5' floppy, with 640KB and 512 bytes/sector."
    Case 15
      MediaType = "A 5.25' floppy, with 640KB and 512 bytes/sector."
    Case 16
      MediaType = "A 5.25' floppy, with 720KB and 512 bytes/sector."
    Case 17
      MediaType = "A 3.5' floppy, with 1.2MB and 512 bytes/sector."
    Case 18
      MediaType = "A 3.5' floppy, with 1.23MB and 1024 bytes/sector."
    Case 19
      MediaType = "A 5.25' floppy, with 1.23MB and 1024 bytes/sector."
    Case 20
      MediaType = "A 3.5' floppy, with 128MB and 512 bytes/sector."
    Case 21
      MediaType = "A 3.5' floppy, with 230MB and 512 bytes/sector."
    Case 22
      MediaType = "An 8' floppy, with 256KB and 128 bytes/sector."
    Case 23
      MediaType = "A 3.5' floppy, with 200MB and 512 bytes/sector. (HiFD)."
    Case 24
      MediaType = "A 3.5' floppy, with 240MB and 512 bytes/sector. (HiFD)."
    Case 25
      MediaType = "A 3.5' floppy, with 32MB and 512 bytes/sector."
    Default
      MediaType = "Format is unknown"
  EndSelect
  ProcedureReturn MediaType
EndProcedure
 
Procedure.b GetCD_Geometry(drive.s)
  hDevice.l;               ; дескриптор проверяемого устройства
  junk.l                   ; сбрасываем результаты
  ; открываем устройство
  hDevice = CreateFile_("\\.\\" + drive, #GENERIC_READ, #FILE_SHARE_READ | #FILE_SHARE_WRITE, 0, #OPEN_EXISTING, #FILE_ATTRIBUTE_NORMAL, 0)
  If hDevice = #INVALID_HANDLE_VALUE               ; невозможно открыть устройство
      ProcedureReturn #False
  Else
      pdg.DISK_GEOMETRY_EX
      If DeviceIoControl_(hDevice, #IOCTL_DISK_GET_DRIVE_GEOMETRYEX, #Null, 0, @pdg, SizeOf(pdg), @junk, #Null)
          Debug "Cylinders = " + Str(pdg\geometry\Cylinders)
          Debug "Tracks per cylinder = " + Str(pdg\geometry\TracksPerCylinder)
          Debug "Sectors per track = " + Str(pdg\geometry\SectorsPerTrack)
          Debug "Bytes per sector = " + Str(pdg\geometry\BytesPerSector)
          Debug GetMediaType(pdg\geometry\MediaType)
          Debug Convert(pdg\DiskSize, 2)
      Else  
          CloseHandle_(hDevice)
          ProcedureReturn #False
      EndIf  
  EndIf    
  CloseHandle_(hDevice)
 
  ProcedureReturn #True
EndProcedure
 
  For i = 65 To 90
    If GetDriveType_(Chr(i) + ":\") = #DRIVE_CDROM
      Break
    EndIf
  Next
GetCD_Geometry(Chr(i) + ":")


_________________
Всё должно быть просто, настолько просто, насколько возможно, но не проще. (c) Альберт Эйнштейн
Изображение


Вернуться наверх
 Профиль  
 
 Заголовок сообщения:
СообщениеДобавлено: Пн мар 12, 2012 3:58 pm 
Не в сети
МОДЕРАТОР

Зарегистрирован: Вт дек 05, 2006 8:46 am
Сообщений: 6220
Благодарил (а): 16 раз.
Поблагодарили: 173 раз.
Пункты репутации: 48
Если в системе несколько CDROM ( виртуальные + реальный) то не сработает это:
pablov писал(а):
For i = 65 To 90
If GetDriveType_(Chr(i) + ":") = #DRIVE_CDROM
Break
EndIf
Next
GetCD_Geometry(Chr(i) + ":")


Так работает:
Код:
1
2
3
4
5
6
7
8
 
 For i = 65 To 90
    If GetDriveType_(Chr(i) + ":") = #DRIVE_CDROM
      Debug Chr(i) + ":"
      GetCD_Geometry(Chr(i) + ":")
    EndIf
  Next
 


_________________
read-only


Вернуться наверх
 Профиль  
 
Показать сообщения за:  Сортировать по:  
Начать новую тему Ответить на тему  [ Сообщений: 37 ]  На страницу 1, 2, 3  След.

Часовой пояс: UTC + 3 часа


Кто сейчас на форуме

Сейчас этот форум просматривают: нет зарегистрированных пользователей и гости: 1


Вы не можете начинать темы
Вы не можете отвечать на сообщения
Вы не можете редактировать свои сообщения
Вы не можете удалять свои сообщения
Вы не можете добавлять вложения

Найти:
Перейти:  
Создано на основе phpBB® Forum Software © phpBB Group (блог о phpBB)
Сборка создана CMSart Studio
Русская поддержка phpBB