VBNet - Форум - Picture изменение размеров,рисование,сохранение

Вопрос: Picture изменение размеров,рисование,сохранение Добавлено: 04.02.07 20:21

Автор вопроса: Боцман | Web-сайт: Rus-Skipper.narod.ru | ICQ: 295725312

Вижу частые вопросы на форуме по этим пунктам.
Решил написать пример, сильно не ругайте за код,
как умею так и пишу.

Создайте проект, и расположите на нем два Picture.
Запускайте и пользуйтесь.

Option Explicit
' Для диалога открытия  и сохранения файла
Type OPENFILENAME
         lStructSize As Long
         hwndOwner As Long
         hInstance As Long
         lpstrFilter As String
         lpstrCustomFilter As String
         nMaxCustFilter As Long
         nFilterIndex As Long
         lpstrFile As String
         nMaxFile As Long
         lpstrFileTitle As String
         nMaxFileTitle As Long
         lpstrInitialDir As String
         lpstrTitle As String
         flags As Long
         nFileOffset As Integer
         nFileExtension As Integer
         lpstrDefExt As String
         lCustData As Long
         lpfnHook As Long
         lpTemplateName As String
       End Type

Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
         "GetOpenFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32" Alias _
         "GetSaveFileNameA" (pOPENFILENAME As OPENFILENAME) As Long
'**********************************************************************
' код ошибки
Declare Function CommDlgExtendedError Lib "comdlg32" () As Long

Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

код в форме;

Option Explicit
'******CreatePopupMenu создает новое всплывающее меню. + Function mnuMenu *********
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As Any) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
    X As Long
    Y As Long
End Type
'**********************************************************************************
'Функция StretchBlt копирует часть изображения от одного Picture в
'другое. Эта функция также позволяет масштабировать (сжимать, растягивать,
'выворачивать наизнанку, задавая параметры с разными знаками)
Private Declare Function StretchBlt Lib "gdi32" _
           (ByVal hdc 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 hSrcWidth As Long, ByVal nSrcHeight As Long, _
           ByVal dwRop As Long) As Long
Const SRCCOPY = &HCC0020 'мы же используем -Точное копирование исходного изображения
'***********************************************************************************
'********' обработка ошибок CmdDialog
Private Const FNERR_BUFFERTOOSMALL = &H3003
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
'*************************************************
Dim ris As Byte
Public Function mnuMenu()
Dim kordinata As POINTAPI
Dim newMenu As Long
Dim klicMenu As Long
    newMenu = CreatePopupMenu() ' Создадим вначале пустое меню
    AppendMenu newMenu, 0, 1, "О программе" ' Добавим новые пункты к меню
    AppendMenu newMenu, &H800, 0, vbNull
    AppendMenu newMenu, 0, 2, "Открыть фото"
    AppendMenu newMenu, 0, 3, "Сохранить фото"
    AppendMenu newMenu, 0, 4, "Закрыть программу"
    GetCursorPos kordinata
    klicMenu = TrackPopupMenu(newMenu, 2 Or &H100, kordinata.X, kordinata.Y, 0, hwnd, 0)
    If klicMenu = 1 Then MsgBox "Автор Rus-Skipper   http://Rus-Skipper.narod.ru ", 0, ""
      If klicMenu = 2 Then openFoto
      If klicMenu = 3 Then saveFoto
      If klicMenu = 4 Then Unload Form1
    DestroyMenu newMenu ' Уничтожаем наше меню
End Function
Public Function openFoto()
Picture2.Picture = LoadPicture() 'очищаем от рисунка что бы не было наложения с предыдущим
Dim OpenFile As OPENFILENAME
Dim lRet As Long
Dim sFilter As String
Dim errcode As Long
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = Form1.hwnd
OpenFile.hInstance = App.hInstance
' ' Здесь устанавливаем типы файлов которые будем искать
sFilter = "Графические файлы " & Chr(0) & "*.jpg;*.bmp;*.gif" & Chr(0) & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = CurDir 'начинаем поиск с  папки открытой последней
OpenFile.lpstrTitle = "Ищем Графические файлы"
OpenFile.flags = 0
lRet = GetOpenFileName(OpenFile)
If lRet = 0 Then
        errcode = CommDlgExtendedError() ' получаем код ошибки для GetOpenFileName
Else
    Picture1.Picture = LoadPicture(Trim(OpenFile.lpstrFile))
End If
  AutoSizeFoto 'изменяем размеры и показываем фото
  Form1.Caption = "Нажмите левую кнопку мыши и рисуйте"
End Function
'***сохранение фото в Picture2 с измененными размерами********
  Public Function saveFoto()
  Dim filebox As OPENFILENAME  ' структура для управления диалоговым окном
Dim fname As String  ' путь и имя файла
Dim lRet As Long  ' возвращаемое значение
filebox.lStructSize = Len(filebox)  ' размер структуры
filebox.hwndOwner = Form1.hwnd  ' дескриптор формы
filebox.hInstance = App.hInstance
filebox.lpstrTitle = "Сохранение файла"  ' текст для заголовка диалогового окна
' Здесь устанавливаем видимые типы файлов У нас (*.bmp)а могут бить и (*.txt)например
filebox.lpstrFilter = "Графические файлы (*.bmp)" & Chr(0) & "*.BMP" & Chr(0)
filebox.nFilterIndex = 1
filebox.lpstrFile = String(257, 0)   ' создаем буфер для приема пути и имени файла
filebox.nMaxFile = Len(filebox.lpstrFile) - 1  ' длина для этого буфера
filebox.lpstrFileTitle = filebox.lpstrFile  ' создаем буфер для приема имени выбранного файла
filebox.nMaxFileTitle = filebox.nMaxFile ' длина для этого буфера
filebox.lpstrDefExt = ".bmp"  ' расширение файла по умолчанию
filebox.lpstrInitialDir = CurDir '=Environ("USERPROFILE") 'откроет Documents and Settings\ваша учетная запись
filebox.flags = 0
lRet = GetSaveFileName(filebox)
If lRet <> 0 Then  '<> 0 пользователь выбрал файл
' Извлекаем имя файла из буфера и передаем его fname=(полный путь + имя и расширение)
fname = Left(filebox.lpstrFile, InStr(filebox.lpstrFile, vbNullChar) - 1)
SavePicture Picture2.Image, fname 'сохраняем файл из Picture2 в выбранную директорию.
End If
  End Function
'*******изменение размеров фото и подгонка размеров формы по размерам фото
Public Function AutoSizeFoto()
Dim kF As String
kF = Picture1.Width / Picture1.Height 'расчет коэффициента
If kF > 1.33 Then ' это коэффициент для обычного стандарта фото
Picture2.Width = 600 'здесь нужная максимальная ширина в проекте
Picture2.Height = Picture2.Width / kF
Else
Picture2.Height = 400 'здесь нужная максимальная высота в проекте
Picture2.Width = Picture2.Height * kF
End If
Picture2.Left = 0
Picture2.Top = 0
Dim py As Long 'узнаем величину заголовка формы,
'для этого Form1.ScaleHeight переводим в твипы
py = Form1.Height - ScaleX(Form1.ScaleHeight, vbPixels, vbTwips)
Dim px As Long ' то же для ширины, определяем размер бордюра
px = Form1.Width - ScaleX(Form1.ScaleWidth, vbPixels, vbTwips)
'Задаем размеры формы по полученному рисунку
Form1.Width = ScaleX(Picture2.Width, vbPixels, vbTwips) + px
Form1.Height = ScaleY(Picture2.Height, vbPixels, vbTwips) + ScaleY(0, vbPixels, vbTwips) + py
'копируем изоражение из Picture1 в Picture2 или точнее рисуем, но сновыми размерами
StretchBlt Picture2.hdc, 0, 0, Picture2.Width, Picture2.Height, Picture1.hdc, 0, 0, Picture1.Width, Picture1.Height, SRCCOPY
Picture2.Refresh ' "освежаем" рисунок для точного вывода вида, при постоянном открытии новых фото
End Function
Private Sub Form_Load()
Form1.Caption = "Нажмите правую кнопку мыши"
Form1.ScaleMode = vbPixels
Picture1.ScaleMode = 3
Picture2.ScaleMode = 3
Picture1.AutoSize = True
Picture1.Visible = False
Picture1.AutoRedraw = True
Picture2.AutoRedraw = True
ris = 2
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button And vbRightButton Then mnuMenu 'проверка, нажата ли правая клавиша мыши
End Sub
Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button And vbRightButton Then Exit Sub 'проверка, нажата ли правая клавиша мыши
Picture2.ForeColor = vbRed
Picture2.PSet (X, Y) 'рисуем точку
ris = 1
End Sub
Private Sub Picture2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ris = 2 Then Exit Sub
Picture2.DrawWidth = 10
Picture2.Line -(X, Y) 'рисуем линию
End Sub
Private Sub Picture2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button And vbRightButton Then mnuMenu 'если правая открываем меню'
ris = 2
End Sub

Ответить

Ответы Всего ответов: 6

Номер ответа: 1 Автор ответа: Fever Вопросов: 60 Ответов: 808	Профиль \| \| #1	Добавлено: 04.02.07 20:55
	А почему не в примеры? Вот ссылочка: http://www.vbnet.ru/upload/ Ответить

Номер ответа: 2 Автор ответа: Серёга ICQ: 262809473 Вопросов: 17 Ответов: 561	Web-сайт: houselab.narod.ru Профиль \| \| #2	Добавлено: 04.02.07 21:02
	Цвета искажает, но это легко поправить : 1. В раздел деклораций добавляем Const HALFTONE = 4 Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long 2. В функцию AutoSizeFoto() перед StretchBlt добавляем If GetStretchBltMode(Picture2.hdc) <> HALFTONE Then SetStretchBltMode Picture2.hdc, HALFTONE End If и всё На мой взгляд в примере... (как бы это по - мягче сказать... ) не всё относится к теме рисования, но может быть это и к лучшему )) Ответить

Номер ответа: 3 Автор ответа: Боцман ICQ: 295725312 Вопросов: 53 Ответов: 830	Web-сайт: Rus-Skipper.narod.ru Профиль \| \| #3	Добавлено: 04.02.07 21:28
	Спасибо за подсказку.А насчет рисования я имел в виду только что-то там "намалевать" и сохранить в файл, но уже с новыми размерами. Пределов совершенству нет... Ответить

Номер ответа: 4 Автор ответа: Боцман ICQ: 295725312 Вопросов: 53 Ответов: 830	Web-сайт: Rus-Skipper.narod.ru Профиль \| \| #4	Добавлено: 04.02.07 22:04
	Серёга! Const HALFTONE = 4 Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long С первой попытки не работет, а потом все ОК'. SetStretchBltMode ,GetStretchBltMode в guide у меня нет, нечего посмотреть. HALFTONE = 4 что это и какие еще есть? Ответить

Номер ответа: 5 Автор ответа: Серёга ICQ: 262809473 Вопросов: 17 Ответов: 561	Web-сайт: houselab.narod.ru Профиль \| \| #5	Добавлено: 04.02.07 22:20
	iStretchMode Specifies the stretching mode. It can be one of the following values: BLACKONWHITE=1 Performs a Boolean AND operation using the color values for the eliminated and existing pixels. If the bitmap is a monochrome bitmap, this mode preserves black pixels at the expense of white pixels. COLORONCOLOR=3 eletes the pixels. This mode deletes all eliminated lines of pixels without trying to preserve their information. HALFTONE=4 Maps pixels from the source rectangle into blocks of pixels in the destination rectangle. The average color over the destination block of pixels approximates the color of the source pixels. After setting the HALFTONE stretching mode, an application must call the SetBrushOrgEx function to set the brush origin. If it fails to do so, brush misalignment occurs. STRETCH_ANDSCANS Same as BLACKONWHITE. STRETCH_DELETESCANS Same as COLORONCOLOR. STRETCH_HALFTONE Same as HALFTONE. STRETCH_ORSCANS Same as WHITEONBLACK. WHITEONBLACK=2 Performs a Boolean OR operation using the color values for the eliminated and existing pixels. If the bitmap is a monochrome bitmap, this mode preserves white pixels at the expense of black pixels. Перевотить чё то влом Ты уж сам постарайся )) Ответить

Номер ответа: 6 Автор ответа: Боцман ICQ: 295725312 Вопросов: 53 Ответов: 830	Web-сайт: Rus-Skipper.narod.ru Профиль \| \| #6	Добавлено: 04.02.07 22:27
	Спасибо! Ответить

Страница: 1 |