Страница: 1 |
Страница: 1 |
Вопрос: Размер изображения
Добавлено: 02.02.07 19:28
Автор вопроса: Alex | Web-сайт:
Как выводить картинку сохряняя ее пропорци?
Ответы
Всего ответов: 15
Номер ответа: 1
Автор ответа:
AgentFire
ICQ: 192496851
Вопросов: 75
Ответов: 3178
Профиль | | #1
Добавлено: 02.02.07 19:43
В каком смысле?
Номер ответа: 2
Автор ответа:
Alexandr.R
Вопросов: 9
Ответов: 115
Web-сайт:
Профиль | | #2
Добавлено: 02.02.07 19:48
VB.NET
Номер ответа: 3
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #3
Добавлено: 02.02.07 20:13
VB,6
Это ответ, а вот у меня с картинкам сегодня
БОЛЬШое недоразумение. Может кто подскажет?
Написал вспомогательную продпрогамму для своего проекта, мелочь просто писала код VB для рисования любых придуманных фигур от щелчка мыши.
Понадибилось, написал очередной код в ней сохранил и тут отвлекся,
а когда пришел увидел предупреждение о не хватке
виртуальной памяти. Закрыл все приложения и перезапустил винду, а она не грузится пишет что-то и ссылается на мой проект. Он был на диске F
,загружаю операционку диск С то-же самое.
С третей попытки зашел на диск С. Сразу посмотрел,что там с проектом, а файлы то все исчезли при чем в вложенных подпапках все нормально. Проект не новый (недельный)и его я точно закрывал. Вобщем СТУПОР.
Что же это было?
Номер ответа: 4
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #4
Добавлено: 02.02.07 20:18
Alex извени вот код, задумался.
Номер ответа: 5
Автор ответа:
Stars
Вопросов: 41
Ответов: 239
Профиль | | #5
Добавлено: 03.02.07 14:53
Насчёт пропажи файлов может просто у тебя HDD битый и случайно совершенно на какойнить битый сектор попала твоя прога и вполне реально что при загрузке винды идёт считывание файловой системы с насителя и тут доходит до битьго места и тутушки начинаются гюки!Проверь на ошибки HDD, на вирусы на всякий случай Всёравно если чё проверки никогда не помешают
Номер ответа: 6
Автор ответа:
Alex
Вопросов: 13
Ответов: 26
Web-сайт:
Профиль | | #6
Добавлено: 04.02.07 15:59
Не эт понятно что Picture1.AutoSize=True. Я имею ввиду есть поле 300Х300 как в него вывсести картинку с размером 1024Х768 с сохранением пропорций?
Номер ответа: 7
Автор ответа:
Серёга
ICQ: 262809473
Вопросов: 17
Ответов: 561
Web-сайт:
Профиль | | #7
Добавлено: 04.02.07 16:42
Так ты пересчитай размеры то, и PaintPicture её туда. И всё
Номер ответа: 8
Автор ответа:
AgentFire
ICQ: 192496851
Вопросов: 75
Ответов: 3178
Профиль | | #8
Добавлено: 04.02.07 17:14
смотришь, какой больше - ширина или высота. в данном случае - ширина(1024)
значит, делаешь так:
НоваяШирина=ТекущаяШирина*k
НоваяВысота=ТекущаяВысота*k
Номер ответа: 9
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #9
Добавлено: 04.02.07 19:20
не путай с Image Picture обрежет.
Я написал пример как это сделать.Попробую сейчас вставить хотя он более для библиотеки кодов сгодился бы, но это как админы решат.
Итак открой проект и кинь туда два Picture
размеры не имеют значения. Вот код.
вначале в модуле;
' Для диалога открытия и сохранения файла
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
'******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
 estroyMenu 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
на сколько мог пользуйтесь.
Номер ответа: 10
Автор ответа:
AgentFire
ICQ: 192496851
Вопросов: 75
Ответов: 3178
Профиль | | #10
Добавлено: 05.02.07 00:27
Не ну ниФИГА себе ты там написан! Мой-то вариант чем тебе не угодил, я что-то не понял?
Номер ответа: 11
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #11
Добавлено: 05.02.07 00:51
А ты попробуй свой код в проекте, и сравни с моим тогда увидишь, что твой обрежет рисунок, а мой сожмет...
Номер ответа: 12
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #12
Добавлено: 05.02.07 01:20
Создай проект кинь Picture1 если у тебя не ХР,
то укажи другой путь к картинке.
Form1.Caption = "Кликни по картинке"
Picture1.AutoSize = True
Picture1.Picture = LoadPicture("C:\WINDOWS\Зеленый камень.bmp"
End Sub
Private Sub Picture1_Click()
Dim k As Long
k = 1300 / Picture1.Width
Picture1.Width = Picture1.ScaleWidth * k
Picture1.Height = Picture1.ScaleHeight * k
End Sub
это твое предложение, оно обрежит картинку.
Номер ответа: 13
Автор ответа:
AgentFire
ICQ: 192496851
Вопросов: 75
Ответов: 3178
Профиль | | #13
Добавлено: 05.02.07 15:18
Я, о великий Боцман, положу в PictureBox Image, поставлю ему Stretch=True и буду насладжаться жизнью
Номер ответа: 14
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #14
Добавлено: 05.02.07 15:55
6 Не эт понятно что Picture1.AutoSize=True.
7 Так ты пересчитай размеры то, и PaintPicture её туда. И всё
8 твой ответ на "Не эт понятно что Picture1.AutoSize=True."
9 не путай с Image, Picture обрежет.
А насчет Image "Stretch=True и буду насладжаться жизнью" , а рисование, изменение размеров с сохранением в файл то-же в Image?
или всеравно к посту 7 придешь.
Picture2.PaintPicture Picture1, 0, 0, 300, 300, 0, 0, , , vbSrcCopy
Номер ответа: 15
Автор ответа:
Боцман
ICQ: 295725312
Вопросов: 53
Ответов: 830
Web-сайт:
Профиль | | #15
Добавлено: 05.02.07 16:19
К стати, Серега поскозал код для "Ретуши"
1. В раздел деклораций добавляем
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 Picture2.hdc, HALFTONE
End If