Справочник функций

Ваш аккаунт

Войти через: 
Забыли пароль?
Регистрация
Информацию о новых материалах можно получать и без регистрации:

Почтовая рассылка

Подписчиков: -1
Последний выпуск: 19.06.2015

Доступ к графическим файлам на Vba

3.9K
11 июня 2004 года
Alexxxander
9 / / 23.10.2003
Как на VBA получить доступ к характеристикам (в частности, к размеру) графических файлов (напр., tiff)?
648
11 июня 2004 года
Tiraspolsky
220 / / 23.07.2003
Цитата:
Originally posted by Alexxxander
Как на VBA получить доступ к характеристикам (в частности, к размеру) графических файлов (напр., tiff)?



Изучи структуру файла и прочитай соответствующие параметры в заголовке файла.

648
11 июня 2004 года
Tiraspolsky
220 / / 23.07.2003
Цитата:
Originally posted by Alexxxander
Как на VBA получить доступ к характеристикам (в частности, к размеру) графических файлов (напр., tiff)?



Для файлов gif и jpg я в свое время это проделал.

Код:
Private Function getHWgif(file As String, X As Long, Y As Long) As Boolean
    Dim w As Integer, h As Integer, s As String * 3
    w = CInt(X)
    h = CInt(Y)
    On Error GoTo sos1
    getHWgif = False
    Open file For Binary As #1
    Get #1, , s
    If s <> "GIF" Then
        MsgBox file & " - не файл формата GIF"
        Close #1
        Exit Function
    End If
    Get #1, , s 'версия
    Get #1, , w
    Get #1, , h
    Close #1
    X = CLng(w)
    Y = CLng(h)
    If X = 0 Or Y = 0 Then MsgBox file & " - Invalid image (H=0 OR W=0)" Else getHWgif = True
    Exit Function
sos1:
    MsgBox Err.Description
End Function

Private Function getHWjpg(file As String, X As Long, Y As Long) As Boolean
    Dim s As String, s1 As String, j As Long, i As Integer, n As Integer, k As Integer
    Dim h As Long, b As Byte
    On Error GoTo sos
    getHWjpg = False
    Open file For Binary As #1
    Get #1, , i
    If Not Hex(i) = "D8FF" Then
        MsgBox file & " - не файл формата JPEG"
        Close #1
        Exit Function
    End If
    While Not EOF(1)
        Get #1, , i
        If Hex(i) <> "C0FF" Then
            GoSub nextSegment
        Else
            Get #1, , i 'длина сегмента
            Get #1, , b 'точность
            For k = 0 To 1
                Get #1, , i
                GoSub calc
                If k = 0 Then
                    Y = j 'высота pixels
                Else
                    X = j 'ширина pixels
                End If
            Next
            Close #1
            If X = 0 Or Y = 0 Then MsgBox file & " - Invalid image (H=0 OR W=0)" Else getHWjpg = True
            Exit Function
        End If
    Wend
    MsgBox "Не найдено начало кадра"
    Close #1
    Exit Function
nextSegment:
    Get #1, , i
    GoSub calc 'j - длина сегмента
    h = Seek(1)
    Seek #1, h + j - 2
    Return
calc:
    s = Hex(i)
    s = String(4 - Len(s), "0") & s
    s = Right$(s, 2) & Left$(s, 2)
    j = 0
    For i = 0 To 3
        s1 = Mid$(s, 4 - i, 1)
        If s1 < "A" Then n = Val(s1) Else n = Asc(s1) - 55
        j = j + n * 16 ^ i
    Next
    Return
sos:
    MsgBox Err.Description
End Function
Реклама на сайте | Обмен ссылками | Ссылки | Экспорт (RSS) | Контакты
Добавить статью | Добавить исходник | Добавить хостинг-провайдера | Добавить сайт в каталог