Как рисовать API-функциями из VBA?

[litvin44]

Стоит задача: средствами VBA создать растровое изображение (на основе заданных данных) и вставить его в документ.

В VB можно нарисовать с помощью GDI API-функций, указывая дискриптор (hDC) Form или PictureBox. А потом просто скопировать в Clipboard Form.Image или PictureBox.Image.
Но VBA не поддерживает PictureBox, а у UserForm нет свойств hDC и Image

Что можно придумать? На чем рисовать?

[EducatedFool]

Но VBA не поддерживает PictureBox, а у UserForm нет свойств hDC и Image

И что из этого? Если какого-то свойства нет, это ещё не значит, что его не возможно получить...
Вбиваем в поиск по разделу Microsoft Office Excel слово hDC, и сразу обнаруживаем то, что искали:
http://www.programmersforum.ru/showp...63&postcount=2

Вот пример рисования на форме:

[litvin44]

Мне нужны не функции рисования, а способ получения hDC и способ копирования.

Там еще ссылки есть
1-я не работает
2-я отсылает на сайт, где нужна регистрация
3-я про работу с фреймом

Вы бы еще в гуугл отослали...

[EducatedFool]

Вы бы еще в гуугл отослали...

Впрочем, туда Вас и следовало послать.

В прикреплённом к предыдущему сообщению файле есть пример получения hDC формы:

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Public hdc As Long
Public hwnd As Long    'DC of userform
Public PCF As Double    ' a convertion factor to for API pixles to excel points

Sub Setup()
    NewPen    ' make new pen
    GetFormsDC    ' get DC for form
    SelectDrawingObj_into_DC (hNewPen)    ' sets pen into for,
    PCF = PointsPerPixel    ' returns convertion fatcor
End Sub

Sub NewPen()
    hNewPen = CreatePen(PS_SOLID, 0, RGB(225, 0, 0))
End Sub
Sub CreateBrush()
    hNewBrush = CreateSolidBrush(RGB(225, 180, 0))
End Sub

Function GetFormsDC()
    hwnd = FindWindow("thunderDFrame", frmDraw.Caption)
    hdc = GetDC(hwnd)
End Function

Function SelectDrawingObj_into_DC(ByVal lObject As Long)
    Dim hSelect As Long
    hSelect = SelectObject(lObject, hdc)
End Function

Sub ReleaseSessionDC()
    Dim Rc As Long
    hwnd = FindWindow("thunderDFrame", frmDraw.Caption)
    Rc = ReleaseDC(hwnd, hdc)
End Sub

Function Draw(ByVal x As Integer, ByVal y As Integer)
    LineTo hdc, (x / PCF), (y / PCF)
End Function

Sub DeleteObject_Pen(ByVal Object As Long)
    DeleteObject (Object)
End Sub

Public Function PointsPerPixel() As Double
    Dim hdc As Long
    Dim lDotsPerInch As Long

    'Get the Device Context of the desktop window (i.e. the screen)
    hdc = GetDC(0)

    'Get the user's DPI setting
    lDotsPerInch = GetDeviceCaps(hdc, LOGPIXELSX)

    'Divide the 72 points-per-inch by the dpi to give the width of a pixel
    PointsPerPixel = POINTS_PER_INCH / lDotsPerInch

    'Release the Device Context, to tidy up
    ReleaseDC 0, hdc
End Function

А если бы Вы воспользовались моим советом по поиску в разделе с ключевым словом hDC, то нашли бы это сообщение, в котором есть ссылки на примеры получения изображения (скриншота) формы.

Ну а если Вас не устраивают приведённые примеры - идите Вы в Google

[litvin44]

Спасибо!
Буду разбираться.

Но, вообще-то я планировал без формы, а с созданием растра в памяти

[EducatedFool]

Стоит задача: средствами VBA создать растровое изображение

Если не секрет, кто поставил такую задачу?
Есть ли ограничения по применяемым средствам?

Я, к примеру, использую CorelDRAW для формирования графических файлов (можно работать с CorelDRAW непосредственно - в него встроен VBA, можно из любого другого приложения, подключив библиотеку CorelDRAW)

Вот пример кода VBA для CorelDRAW, который создаёт несколько папок, в каждой из которых формируются растровые изображения отдельных букв:

Sub СформироватьФайлы()
    On Error Resume Next: MyColor = 0
    f = Replace(ThisDocument.FullFileName, ThisDocument.filename, "Letters\"): MkDir f

    Dim coll As New Collection
    coll.Add "Courier New": coll.Add "Arial": coll.Add "Book Antiqua"
    coll.Add "Comic Sans MS": coll.Add "Lucida Fax"

    Dim doc As Document: Set doc = CreateDocument()

    For Each it In coll
        MyPath = f & it & "\": Debug.Print MyPath: MkDir MyPath: MyColor = MyColor + 1
        For i = 32 To 255
            Debug.Print i, Chr(i): СоздатьФайлСБуквой i, doc, it, MyPath, MyColor: DoEvents
        Next
    Next it
    doc.Close
End Sub

Sub СоздатьФайлСБуквой(ByVal ASC_letter As Byte, ByRef doc As Document, _
                       ByVal Fontname As String, ByVal MyPath As String, ByVal MyColor As Integer)
    doc.MasterPage.SetSize 0.5, 1.5
    Dim l As Layer: Set l = ActiveLayer

    Dim s1 As Shape: Set s1 = l.CreateRectangle(-0.05, -0.1, 0.28, 0.33)
    s1.Fill.ApplyNoFill
    s1.Outline.SetProperties 0.003, OutlineStyles(0), CreateCMYKColor(0, 0, 1, 0), _
                             ArrowHeads(0), ArrowHeads(0), False, False, _
                             cdrOutlineButtLineCaps, cdrOutlineMiterLineJoin, 0#, 100, , , 5#

    Dim sha As Shape
    Set sha = l.CreateArtisticText(0, 0, Chr(ASC_letter), , , Fontname, 25, cdrTrue, cdrTrue)
    Select Case MyColor
        Case 1: sha.Fill.UniformColor.CMYKAssign 0, 99, 0, 0    '    coll.Add "Courier New"
        Case 2: sha.Fill.UniformColor.CMYKAssign 99, 0, 0, 0    '    coll.Add "Arial"
        Case 3: sha.Fill.UniformColor.CMYKAssign 50, 0, 100, 50      '    coll.Add "Book Antiqua"
        Case 4: sha.Fill.UniformColor.CMYKAssign 0, 0, 99, 0    '    coll.Add "Comic Sans MS"
        Case 5: sha.Fill.UniformColor.CMYKAssign 0, 0, 0, 99    '    coll.Add "Lucida Fax"
    End Select

    'CreateExtrude_forSHAPE sha

    Dim expflt As ExportFilter
    Set expflt = doc.ExportBitmap(MyPath & ASC_letter & ".jpg", cdrJPEG, cdrAllPages, _
                                  cdrRGBColorImage, 50, 80, , , cdrNormalAntiAliasing, _
                                  False, False, True, False, cdrCompressionNone)
    With expflt
        .Progressive = True: .Optimized = True: .SubFormat = 0
        .Compression = 10: .Smoothing = 10: .Finish
    End With
    sha.Delete
End Sub

[litvin44]

Будете смеяться, но мне наоборот, в CorelDraw вставить надо.

Растр не рисуется в обычном понимании, а строится на основании определенных данных данных. Вроде карты по x,y,z, где z отображается цветом. Детализация довольно высокая и рисовать непосредственно в CorelDraw не реально – сотни тысяч прямоугольноков разного цвета.

А можно я потом задам вам вопрос про программный вывод текста в CorelDraw?
Макрорекордер его не пишет, а я не профессионал.

[doober]

А почему бы Вам не использовать для этих целей Автокад совместно с RasterDesk Pro 7.5.Автокад позволяет такую детализацию,да и куча макросов есть для ускорения построений

[EducatedFool]

Будете смеяться, но мне наоборот, в CorelDraw вставить надо.

Ну тогда только программы от Corel и надо использовать.

Детализация довольно высокая и рисовать непосредственно в CorelDraw не реально – сотни тысяч прямоугольноков разного цвета.

А Вы пробовали? Всё реально.
В Вашем случае можно использовать VBA в приложении Corel PHOTO-PAINT - формировать изображение попиксельно (или рисовать его из прямоугольников)

Будут подробности по заданию (откуда брать данные, что надо получить в результате) - попробую помочь.

[litvin44]

Сообщение от doober

А почему бы Вам не использовать для этих целей Автокад совместно с RasterDesk Pro 7.5.Автокад позволяет такую детализацию,да и куча макросов есть для ускорения построений

А почему бы мне не говорить по китайски? Потому, что живу в России.

Мне надо в Corel, а не в AutoCad