Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Simple displaying and printing of text and graphics using IE-control

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • Simple displaying and printing of text and graphics using IE-control

    ' simple displaying and printing of text and graphics using ie-control
    ' ====================================================================
    '
    ' comment here please:
    http://www.powerbasic.com/support/pb...ad.php?t=10177
    '
    ' many thanks to terry reese for his original ie-control code at this link:
    http://www.powerbasic.com/support/pb...ead.php?t=8184
    ' i could not have made this program without his code.
    '
    ' march 27th 2004: some improvements have been made. if you have ie-6,
    ' enhanced metafile graphics are printed in correct colors.

    '
    ' march 31st 2004: a small problem with repainting has been
    ' corrected thanks to brad byrne, who provided the necessary
    ' inspiration.

    '
    ' using the ie-control you can display and print text and graphics output
    ' from your pb-programs in a simple and easy way. this program demonstrates
    ' how. the formating of the output is made using the standard html-tags.
    ' the most common of these tags are shown below. normally you would only
    ' need very few as demonstrated in this program.
    '
    ' the text output from your program should be presented to the ie-control
    ' in condensed form as a single text-string with html-tags inserted where
    ' specific formatting features are needed. by letting your program insert
    ' the relevant html-tags, you can format your text as you wish. normally
    ' you would only need to use very few of them. it is important, however,
    ' that you supply the html-tagged text with a standardized starting and
    ' ending sequence like those shown in this program.
    '
    ' graphics output from pb programs can be saved in enhanced metafiles, which
    ' can be inserted anywhere in the output text-string by placing a html
    ' image tag with an url referring to the graphics file in question. (by the
    ' way, image files in other formats can also be inserted.)
    '
    ' by clicking the right mouse button you can obtain a shortcut menu (slightly
    ' different if you click over a picture or over the text) by which you can
    ' copy to the clipboard or print the content via the printer dialog box. my
    ' version of ie (vers. 5) cannot print the enhanced metafile graphics in
    ' correct colors. i wonder if later versions have solved that problem?
    ' if you copy to word and print from there, the colors are ok. so it seems
    ' to be a problem caused in - at least earlier versions of - the ie printer
    ' driver.
    '
    ' good luck!
    '
    ' best regards,
    '
    ' erik christensen -------- e.chr@email.dk --------- march 23, 2004
    [CODE]
    '****************************************************************************
    ' some common html-tags:
    '****************************************************************************
    ' basic elements
    ' document type <html></html> (beginning and end of file)
    ' title <title></title> (must be in header)
    ' header <head></head> (descriptive info, such as title)
    ' body <body></body> (bulk of the page)
    '
    ' structural definition
    ' heading <h?></h?> (the spec. defines 6 levels)
    ' align heading <h? align=left|center|right></h?>
    ' code <code></code> (for source code listings)
    ' large font size <big></big>
    ' small font size <small></small>
    '
    ' presentation formatting
    ' bold <b></b>
    ' italic <i></i>
    ' underline <u></u>
    ' subscript <sub></sub>
    ' superscript <sup></sup>
    ' preformatted <pre></pre> (display text spacing as-is)
    ' center <center></center> (for both text and images)
    ' font size <font size=?></font> (ranges from 1-7)
    ' change font size <font size="+|-?"></font>
    ' font color <font color="#$$$$$$"></font> (order is red/green/blue)
    ' select font <font face="***"></font>
    ' point size <font point-size=?></font>
    ' weight <font weight=?></font>
    ' base font size <basefont size=?> (from 1-7; default is 3)
    ' marquee <marquee></marquee>
    '
    ' positioning
    ' spacer <spacer>
    ' size <spacer size=?>
    '
    ' graphics
    ' display image <img src="url">
    ' alignment <img src="url" align=top|bottom|middle|left|right>
    ' alignment <img src="url" align=texttop|absmiddle|baseline|absbottom>
    ' dimensions <img src="url" width=? height=?> (in pixels)
    ' <img src="url" width=% height=%> (as percentage of page width/height)
    ' border <img src="url" border=?> (in pixels)
    ' runaround space <img src="url" hspace=? vspace=?> (in pixels)
    ' embed object <embed src="url"> (insert object into page)
    ' object size <embed src="url" width=? height=?>
    '
    ' dividers
    ' paragraph <p></p> (closing tag often unnecessary)
    ' align text <p align=left|center|right></p>
    ' justify text <p align=justify></p>
    ' line break <br> (a single carriage return)
    ' clear textwrap <br clear=left|right|all>
    ' no break <nobr></nobr> (prevents line breaks)
    ' word break <wbr> (where to break a line if needed)
    '
    ' backgrounds and colors
    ' tiled bkground <body background="url">
    ' watermark <body bgproperties="fixed">
    ' bkground color <body bgcolor="#$$$$$$"> (order is red/green/blue)
    ' text color <body text="#$$$$$$">
    '
    ' miscellaneous
    ' url of this file <base href="url"> (must be in header)
    ' base window name <base target="***"> (must be in header)
    '
    '****************************************************************************
    #compile exe
    #register none
    #dim all
    '
    #include "win32api.inc"
    #include "commctrl.inc"
    '
    %idd_form1_labelrawtext = 100
    %idd_form1_labelgraphic1 = 105
    %idd_form1_labelhtmltext = 110
    %idd_form1_labelgraphwindow = 115
    %idd_form1_butmakeoutput = 120
    %idd_form1_butdisplcomboutp = 125
    %idd_form1_buttonexit = 135
    %idd_form1_texthtml = 140
    %idd_form1_textraw = 145
    %idd_form1_butprevfig = 150
    %idd_form1_butnextfig = 155
    '
    global hform1&
    global gerror as long ' stores the error variable
    global curgrano as long
    global totalgrano as long
    global currentpath as string
    global th$, tt$ ' th is for html-tagged text, tt is for plain text.
    global outmade&
    '
    '=======================================================================
    ' the following 7 functions are due to terry reese - thanks
    '=======================================================================
    ' function/sub: createie
    ' description: creates an instance of ie and sets the window properties
    ' of the new session.
    ' variables:
    ' vobj_ie: reference to a variant in the calling code --
    ' this will be the object that you will use in
    ' subsequent calls.
    '=======================================================================
    ' this is a simplified version of terry's original function.
    ' see above link for original version.
    function createie(byref vobj_ie as variant) as long
    local obj_ie as dispatch
    local vtoolbar as variant ' not used - set to zero
    local vmenu as variant ' not used - set to zero
    local vaddressbar as variant ' not used - set to zero
    local vresizable as variant ' not used - set to zero
    local vstatusbar as variant ' not used - set to zero
    local lerror as long
    '
    set obj_ie = new dispatch in "internetexplorer.application"
    if isfalse isobject (obj_ie) then
    function = %false
    else:
    try
    object let obj_ie.toolbar = vtoolbar
    object let obj_ie.menubar = vmenu
    object let obj_ie.addressbar = vaddressbar
    object let obj_ie.resizable = vresizable
    object let obj_ie.statusbar = vstatusbar
    set vobj_ie = obj_ie
    set obj_ie = nothing
    function = %true
    catch
    function = %false
    set obj_ie = nothing
    lerror = err
    end try
    end if
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: navigateto
    ' description: use this function to navigate to a url or file.
    ' this works just like typing into the ie addressbar
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' surl: this is the url/file to load
    '=======================================================================
    function navigateto(vobj_ie as variant, byval surl as string) as long
    local obj_ie as dispatch
    local vurl as variant
    local lerror as long

    set obj_ie = vobj_ie
    let vurl = surl
    try
    object call obj_ie.navigate(vurl)
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: isbusy
    ' description: queries ie to see if the object has finished loading
    ' the current url/file
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' lbusy: return value. 0 = not busy 1 = busy
    '=======================================================================
    function isbusy(vobj_ie as variant, lbusy as long) as long
    local obj_ie as dispatch
    local vvariant as variant
    local lerror as long
    set obj_ie = vobj_ie
    try
    object get obj_ie.busy to vvariant
    lbusy = variant#(vvariant)
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: setheight
    ' description: accesses the ie height property (window)
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' lheight: height of the window
    '=======================================================================
    function setheight(vobj_ie as variant, byval lheight as long) as long
    local obj_ie as dispatch
    local tvariant as variant
    local lerror as long
    set obj_ie = vobj_ie
    try
    let tvariant = lheight
    object let obj_ie.height = tvariant
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: setwidth
    ' description: accesses the ie width property (window)
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' lwidth: width of the window
    '=======================================================================
    function setwidth(vobj_ie as variant, byval lwidth as long) as long
    local obj_ie as dispatch
    local tvariant as variant
    local lerror as long
    set obj_ie = vobj_ie
    try
    let tvariant = lwidth
    object let obj_ie.width = tvariant
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: setcoordinates
    ' description: sets the left and top coordinates of a window. uses the
    ' same screen measurements as returned by getsystemmetrics
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' lleft: left position of the window
    ' ltop: top position of the window
    '=======================================================================
    function setcoordinates(vobj_ie as variant, _
    byval lleft as long, _
    byval ltop as long) as long
    local obj_ie as dispatch
    local vleft as variant
    local vtop as variant
    local lerror as long
    set obj_ie = vobj_ie
    try
    let vleft = lleft
    let vtop = ltop
    object let obj_ie.left = vleft
    object let obj_ie.top = vtop
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '=======================================================================
    ' function/sub: visible
    ' description: sets the window's visiblity
    ' variables:
    ' vobj_ie: this is a reference to a valid object
    ' bool_visible: 0: window will not be visible
    ' 1: window will be visible
    '=======================================================================
    function visible(vobj_ie as variant, _
    byval bool_visible as long) as long
    local obj_ie as dispatch
    local vvariant as variant
    local lerror as long
    set obj_ie = vobj_ie
    select case as long bool_visible
    case %false
    let vvariant = 0
    case %true
    let vvariant = 1
    case else:
    let vvariant = 1
    end select
    try
    object let obj_ie.visible = vvariant
    function = %true
    catch
    function = %false
    lerror = err
    end try
    gerror = lerror
    end function
    '***************************************************************************
    '***************************************************************************
    '***************************************************************************
    function gcolor(byval i as long) as long
    select case i
    ' common rgb colors:
    case 0 : function = &h000000??? '%black - same as rgb(0,0,0)
    case 1 : function = &hff0000??? '%blue
    case 2 : function = &h00ff00??? '%green
    case 3 : function = &hffff00??? '%cyan
    case 4 : function = &h0000ff??? '%red
    case 5 : function = &hff00ff??? '%magenta
    case 6 : function = &h00ffff??? '%yellow
    case 7 : function = &hffffff??? '%white - same as rgb(255,255,255)
    case 8 : function = &h808080??? '%gray
    case 9 : function = &hc0c0c0??? '%ltgray
    ' additional colors can be added e.g. using the rgb function,
    ' e.g. case 10: function = rgb(164,164,164)
    ' and so on.
    case else : function = &h000000??? '%black
    end select
    end function
    ' ------------------------------------------------
    function penstyle(byval i as long) as long
    select case i
    case 0 : function = %ps_solid ' _______
    case 1 : function = %ps_dash ' -------
    case 2 : function = %ps_dot ' .......
    case 3 : function = %ps_dashdot ' _._._._
    case 4 : function = %ps_dashdotdot ' _.._.._
    case else: function = %ps_solid
    end select
    end function
    ' ------------------------------------------------
    function makefont(byval fonttypesize as long,byval fontweight as long, _
    byval italic as long, byval underline as long,byval strikeout as long, _
    byval facename as string) as long
    local lffont as logfont ' logfont structure
    local hdc&,logpixelsy&
    hdc = getdc(%hwnd_desktop)
    'retrieves device-specific information about the number
    'of pixels per logical inch along the screen height
    '(depends on screen resolution setting).
    'this is important to define appropriate font sizes.
    logpixelsy = getdevicecaps(hdc, %logpixelsy)
    releasedc %hwnd_desktop, hdc
    'type logfont defines the attributes of a font.
    'see logfont in the win32 help file
    lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' better than: -(fonttypesize * logpixelsy) \ 72
    ' logical height of font
    lffont.lfwidth = 0 ' logical average character width
    lffont.lfescapement = 0 ' angle of escapement
    lffont.lforientation = 0 ' base-line orientation angle
    lffont.lfweight = fontweight ' font weight
    lffont.lfitalic = italic ' italic attribute flag (0,1)
    lffont.lfunderline = underline ' underline attribute flag (0,1)
    lffont.lfstrikeout = strikeout ' strikeout attribute flag (0,1)
    lffont.lfcharset = %ansi_charset ' character set identifier
    lffont.lfoutprecision = %out_tt_precis ' output precision
    lffont.lfclipprecision = %clip_default_precis ' clipping precision
    lffont.lfquality = %default_quality ' output quality
    lffont.lfpitchandfamily = %ff_dontcare ' pitch and family
    lffont.lffacename = facename ' typeface name string
    ' make font according to specifications
    function = createfontindirect (lffont)
    end function
    ' ------------------------------------------------
    sub makegraph(byval hdc as long,rct as rect,byref da() as single, _
    byref gtext() as string, byval nm as long)
    local hpen as long
    local gtex as asciiz * 200
    local i as long
    local total as single
    local cumul as single
    local pi2 as single
    local pct as long, radius as long
    local recstart as long
    local rc as rect
    local hfont as long
    local xleft as long, ytop as long, xright as long, ybottom as long
    local xstart as long, ystart as long, xend as long, yend as long
    local xtext as long, ytext as long, korr as long
    local x1&,y1&, hbrush&
    x1&=rct.nright
    y1&=rct.nbottom
    fillrect hdc, rct, getstockobject(%white_brush)
    radius = y1&/3.6
    xleft = x1&/2 - radius : xright = x1&/2 + radius
    ytop = y1&/2 - radius : ybottom = y1&/2 + radius

    total=0! : for i=1 to nm : total = total + da(i) : next
    local tc$ : tc$ = "
    for i=1 to nm
    tc = tc + left$(gtext(i)+space$(12),13)+using$("######.## ##.##%",da(i),da(i)*100!/total)+$crlf
    next
    tc = tc + $crlf
    tt = tt + tc : th = th + tc
    '
    hfont = makefont(8,400,0,0,0,"arial") : selectobject hdc, hfont
    '
    pi2=8!*atn(1#) : cumul=0!
    korr=-9 ' empiric correction for height of characters. this may be improved.
    for i=1 to nm
    cumul = cumul + da(i) : pct=fix(100*da(i)/total+0.5)
    xtext = int(x1&/2+(radius-korr)*cos(pi2 * (cumul - da(i)/2) / total)+0.5)
    ytext = int(y1&/2-(radius-korr)*sin(pi2 * (cumul - da(i)/2) / total)+0.5)
    if cos(pi2 * (cumul - da(i)/2) / total) >= 0 then
    settextalign hdc,%ta_left ' text on right side of diagram
    else
    settextalign hdc,%ta_right ' text on left side of diagram
    end if
    gtex=gtext(i)+" ("+ltrim$(str$(pct))+"%)"
    textout hdc, xtext, ytext+korr, gtex, byval len(gtex)
    next
    deleteobject hfont
    '
    xstart=x1&/2+radius: ystart=y1&/2 ' select starting point for pie pieces
    cumul=0!
    for i=1 to nm
    cumul = cumul + da(i)
    xend = int(x1&/2+radius*cos(pi2 * cumul / total)+0.5)
    yend = int(y1&/2-radius*sin(pi2 * cumul / total)+0.5)
    hpen = createpen(penstyle(0), 0, gcolor(i)) : selectobject hdc, hpen
    hbrush = createsolidbrush(gcolor(i)) : selectobject hdc, hbrush
    pie hdc, xleft,ytop,xright,ybottom, xstart, ystart, xend, yend
    deleteobject hpen : deleteobject hbrush
    xstart=xend: ystart=yend
    next

    end sub
    '
    sub showenhmetafile
    local hemf&,hgr1&,hdc&,rct as rect
    hemf = getenhmetafile(bycopy currentpath+"demonstration_figure"+trim$(str$(curgrano))+".emf" )
    hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
    getclientrect hgr1, rct
    hdc = getdc(hgr1)
    call playenhmetafile (hdc, hemf, rct)
    deleteenhmetafile hemf
    releasedc hgr1, hdc
    control set text hform1&, %idd_form1_labelgraphic1, "figure"+str$(curgrano)
    end sub
    '
    callback function form1_dlgproc
    static vobj_ie as variant
    static lret as long
    static ltmp as long
    select case cbmsg
    case %wm_paint
    local hdc&, ps as paintstruct, rc as rect
    beginpaint cbhndl, ps
    if istrue outmade& then
    call showenhmetafile
    else
    getclientrect getdlgitem(cbhndl, %idd_form1_labelgraphwindow), rc
    hdc = getdc(getdlgitem(cbhndl, %idd_form1_labelgraphwindow))
    fillrect hdc, rc, getstockobject(%white_brush)
    releasedc cbhndl, hdc
    end if
    endpaint cbhndl, ps
    case %wm_command
    select case cbctl
    case %idd_form1_butdisplcomboutp
    if cbctlmsg=%bn_clicked then
    if createie(vobj_ie) = 0 then
    error gerror
    msgbox error$,%mb_iconerror,"error in creating ie-dialog"
    end if
    lret = setwidth(vobj_ie, getsystemmetrics (%sm_cxscreen)*0.6)
    lret = setheight(vobj_ie, getsystemmetrics (%sm_cyscreen)*0.6)
    lret = setcoordinates(vobj_ie, getsystemmetrics (%sm_cxscreen)*0.2, getsystemmetrics (%sm_cyscreen)*0.2)
    lret = navigateto(vobj_ie, currentpath+"iecontrdemon.html")
    lret = visible(vobj_ie, 1)
    ltmp = 1
    while ltmp > 0
    lret = isbusy(vobj_ie, ltmp)
    sleep 200 'unless you need to be doing something else
    'its is best to just go to sleep for small
    'periods so that ie can do what it needs
    'to do without constantly being queried by
    'this thread.
    wend
    end if
    '
    case %idd_form1_butnextfig
    if cbctlmsg=%bn_clicked then
    incr curgrano
    if curgrano > totalgrano then curgrano = totalgrano : exit if
    call showenhmetafile
    end if
    if curgrano > 1 then control enable hform1&, %idd_form1_butprevfig
    if curgrano = totalgrano then
    control disable hform1&, %idd_form1_butnextfig
    control set focus hform1&, %idd_form1_butprevfig
    end if
    '
    case %idd_form1_butprevfig
    if cbctlmsg=%bn_clicked then
    decr curgrano
    if curgrano < 1 then curgrano = 1 : exit if
    call showenhmetafile
    end if
    if curgrano < totalgrano then control enable hform1&, %idd_form1_butnextfig
    if curgrano = 1 then
    control disable hform1&, %idd_form1_butprevfig
    control set focus hform1&, %idd_form1_butnextfig
    end if
    case else
    end select
    case else
    end select
    end function
    '
    function graphics(byval no as long,byref da() as single, _
    byref gtext() as string, byval nm as long) as string
    local rct as rect, hgr1&
    local hdcref&,iwidthmm&,iheightmm&,iwidthpels&,iheightpels&
    local hdcemf&, hemf&, hdc&, i&, kk&

    ' get handle to graphics window
    hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
    '
    ' specify rectancle in 0.01 mm units for creation of metafile:
    '
    ' obtain a handle to a reference device context.
    hdcref = getdc(hform1&)
    '
    ' determine the full display dimensions.
    ' iwidthmm is the display width in millimeters.
    ' iheightmm is the display height in millimeters.
    ' iwidthpels is the display width in pixels.
    ' iheightpels is the display height in pixels
    iwidthmm = getdevicecaps(hdcref, %horzsize)
    iheightmm = getdevicecaps(hdcref, %vertsize)
    iwidthpels = getdevicecaps(hdcref, %horzres)
    iheightpels = getdevicecaps(hdcref, %vertres)
    '
    releasedc hform1&, hdcref
    '
    ' retrieve the coordinates of the client rectangle, in pixels.
    getclientrect hgr1,rct
    ' convert client coordinates to .01-mm units.
    ' use iwidthmm, iwidthpels, iheightmm, and
    ' iheightpels to determine the number of
    ' .01-millimeter units per pixel in the x- and y-directions.
    rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
    rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
    rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
    rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
    '
    ' create enhanced metafile
    hdcemf = createenhmetafile (%null, byval %null, rct, byval %null)
    ' get rectangle in pixels to display diagram
    getclientrect hgr1, rct
    call makegraph(hdcemf,rct,da(),gtext(),nm)
    hemf = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
    '
    ' handle to device context of label where the diagram is to be drawn
    hdc = getdc(hgr1)
    ' play enhanced metafile in the label window,
    ' i.e. the graphics procedures are now being performed in that window.
    if no = 1 then
    call playenhmetafile (hdc, hemf, rct)
    control set text hform1&, %idd_form1_labelgraphic1, "figure"+str$(no)
    end if
    releasedc hgr1, hdc
    '
    local curpath as asciiz * 255, st$, pathandfile$, res&
    '
    getmodulefilename getmodulehandle("), curpath, 255 'get current path & exe
    '
    st$=curpath
    '
    currentpath=left$(st$,instr(-1, st$, any ":\/"))
    pathandfile$=currentpath+"demonstration_figure"+trim$(str$(no))+".emf"
    '
    res& = copyenhmetafile(hemf,bycopy pathandfile$) ' save to disk
    deleteenhmetafile hemf
    function = pathandfile$
    end function

    callback function cbf_form1_butmakeoutput
    local i&, kk&, no&, graphfile$, txt$
    dim da(5) as single, gtext(5) as string, su(5) as single
    if cbctlmsg=%bn_clicked then
    ' th is the html text string to be used for the ie control
    ' ***************************
    ' first the html text header:
    ' ***************************
    th = "<html>"+$crlf ' start of html-document
    th = th +"<head>"+$crlf ' start of header
    th = th +"<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">"+$crlf ' technical specification
    txt = "ie display and print demonstration" ' title text
    th = th +"<title>"+txt+"</title>"+$crlf ' title
    th = th +"</head>"+$crlf ' end of header
    th = th +"<body>"+$crlf ' start of body of content
    th = th +"<pre>"+$crlf ' preformatted text
    th = th +"<font face="courier new" color="#0000ff">"+$crlf ' font type and color ' font color
    ' ****************************
    '
    ' tt is the plain text for a textbox
    tt = txt + $crlf + $crlf
    '
    th = th + txt + $crlf + $crlf
    '
    kk = 0
    ' data are completely imaginary
    ' they are only for illustration
    data food, house, clothes, leisure, travel
    for i=1 to 5 : incr kk : gtext(kk)=read$(kk) : next
    '
    data 452.92, 665.40, 87.76, 186.54
    ' expenses period 1
    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
    no = 1
    tt = tt + " period"+str$(no)+$crlf
    th = th + " <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
    curgrano = 1
    graphfile$ = graphics(no, da(), gtext(), 4)
    ' include this graph in the html-tagged text file.
    tt = tt + " figure"+str$(no)+$crlf+$crlf
    th = th + " figure"+str$(no)
    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
    '
    data 438.39, 666.24, 130.65, 230.54
    ' expenses period 2
    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
    incr no
    tt = tt + " period"+str$(no)+$crlf
    th = th + " <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
    graphfile$ = graphics(no, da(), gtext(), 4)
    ' include this graph in the html-tagged text file.
    tt = tt + " figure"+str$(no)+$crlf+$crlf
    th = th + " figure"+str$(no)
    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
    '
    data 410.67, 766.56, 200.65, 250.23, 698.54
    ' expenses period 3
    for i=1 to 5 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
    incr no
    tt = tt + " period"+str$(no)+$crlf
    th = th + " <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
    graphfile$ = graphics(no, da(), gtext(), 5)
    ' include this graph in the html-tagged text file.
    tt = tt + " figure"+str$(no)+$crlf+$crlf
    th = th + " figure"+str$(no)
    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
    '
    data 502.37, 685.23, 41.65, 146.87
    ' ' expenses period 4
    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
    incr no
    tt = tt + " period"+str$(no)+$crlf
    th = th + " <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
    graphfile$ = graphics(no, da(), gtext(), 4)
    ' include this graph in the html-tagged text file.
    tt = tt + " figure"+str$(no)+$crlf+$crlf
    th = th + " figure"+str$(no)
    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
    '
    local total!
    for i = 1 to 5 : total = total + su(i) : next
    incr no
    tt = tt + " results for all 4 periods"+$crlf
    th = th + " <b><i><u>results for all 4 periods</b></i></u>"+$crlf
    graphfile$ = graphics(no, su(), gtext(), 5)
    ' include this graph in the html-tagged text file.
    tt = tt + " figure"+str$(no)+$crlf+$crlf
    th = th + " figure"+str$(no)
    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
    '
    tt = tt + " - - - - -"+$crlf
    th = th + " - - - - -"+$crlf
    ' **********************
    ' end tags of html text:
    ' **********************
    th = th +"</font>"+$crlf
    th = th +"</pre>"+$crlf
    th = th +"</body>"+$crlf
    th = th +"</html>"+$crlf
    ' ***************************
    totalgrano = no
    control set text hform1&, %idd_form1_texthtml, th
    control set text hform1&, %idd_form1_textraw, tt
    '
    ' save html-string as a html-file
    local x& : x& = freefile
    open currentpath+"iecontrdemon.html" for binary as #x&
    put$ #x&, th
    seteof #x& ' important if you have used the same file name before.
    close #x&
    '
    control disable hform1&, %idd_form1_butprevfig
    control enable hform1&, %idd_form1_butnextfig
    control enable hform1&, %idd_form1_butdisplcomboutp
    outmade& = %true ' output flag set to true
    end if
    end function
    ' ------------------------------------------------
    callback function cbf_form1_buttonexit
    if cbctlmsg=%bn_clicked then dialog end hform1&
    end function
    ' ------------------------------------------------
    sub showdialog_form1(byval hparent&)
    local style&, exstyle&
    style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center or %ws_clipchildren
    exstyle& = 0
    dialog new hparent&, "simple displaying and printing of text and

  • #2
    ' simple displaying and printing of text and graphics using ie-control
    ' version 2
    ' ====================================================================
    '
    ' comment please in the link referred to in the beginning of the previous post.
    '
    ' this version incorporates the ie-control as a child window in the
    ' dialog.
    '
    ' april 23 2004. a repaint problem and a resource leak problem
    ' has been corrected thanks to brad byrne.

    '
    ' many thanks to josé roca for his original ie-control code at this link:
    http://www.powerbasic.com/support/pb...ad.php?t=24694
    ' his code is really great stuff. i could not have made this version of
    ' the program without his code.
    '
    ' for this version you need internet explorer version 6 installed
    ' on your computer. if the present code does not run satisfactorily it may
    ' help also to install atl version 2 or higher from one of the links
    ' referred to in the comments thread referred to above.

    ' using the ie-control you can display and print text and graphics output
    ' from your pb-programs in a simple and easy way. this program demonstrates
    ' how. the formating of the output is made using the standard html-tags.
    ' the most common of these tags are shown below. normally you would only
    ' need very few as demonstrated in this program.
    '
    ' the text output from your program should be presented to the ie-control
    ' in condensed form as a single text-string with html-tags inserted where
    ' specific formatting features are needed. by letting your program insert
    ' the relevant html-tags, you can format your text as you wish. normally
    ' you would only need to use very few of them. it is important, however,
    ' that you supply the html-tagged text with a standardized starting and
    ' ending sequence like those shown in this program.
    '
    ' graphics output from pb programs can be saved in enhanced metafiles, which
    ' can be inserted anywhere in the output text-string by placing a html
    ' image tag with an url referring to the graphics file in question. (by the
    ' way, image files in other formats can also be inserted.)
    '
    ' by clicking the right mouse button you can obtain a shortcut menu (slightly
    ' different if you click over a picture or over the text) by which you can
    ' copy to the clipboard or print the content via the printer dialog box.
    ' version 6 of ie prints the enhanced metafile graphics in correct colors.
    '
    ' good luck!
    '
    ' best regards,
    '
    ' erik christensen -------- e.chr@email.dk --------- march 27, 2004
    Code:
    '****************************************************************************
    ' some common html-tags:
    '****************************************************************************
    ' basic elements
    '    document type      <html></html>   (beginning and end of file)
    '    title              <title></title> (must be in header)
    '    header             <head></head>   (descriptive info, such as title)
    '    body               <body></body>   (bulk of the page)
    '
    ' structural definition
    '    heading            <h?></h?>       (the spec. defines 6 levels)
    '    align heading      <h? align=left|center|right></h?>
    '    code               <code></code>   (for source code listings)
    '    large font size    <big></big>
    '    small font size    <small></small>
    '
    ' presentation formatting
    '    bold               <b></b>
    '    italic             <i></i>
    '    underline          <u></u>
    '    subscript          <sub></sub>
    '    superscript        <sup></sup>
    '    preformatted       <pre></pre>             (display text spacing as-is)
    '    center             <center></center>       (for both text and images)
    '    font size          <font size=?></font>    (ranges from 1-7)
    '    change font size   <font size="+|-?"></font>
    '    font color         <font color="#$$$$$$"></font> (order is red/green/blue)
    '    select font        <font face="***"></font>
    '    point size         <font point-size=?></font>
    '    weight             <font weight=?></font>
    '    base font size     <basefont size=?>       (from 1-7; default is 3)
    '    marquee            <marquee></marquee>
    '
    ' positioning
    '    spacer             <spacer>
    '    size               <spacer size=?>
    '
    ' graphics
    '    display image      <img src="url">
    '    alignment          <img src="url" align=top|bottom|middle|left|right>
    '    alignment          <img src="url" align=texttop|absmiddle|baseline|absbottom>
    '    dimensions         <img src="url" width=? height=?>    (in pixels)
    '                       <img src="url" width=% height=%>    (as percentage of page width/height)
    '    border             <img src="url" border=?>            (in pixels)
    '    runaround space    <img src="url" hspace=? vspace=?>   (in pixels)
    '    embed object       <embed src="url">                   (insert object into page)
    '    object size        <embed src="url" width=? height=?>
    '
    ' dividers
    '    paragraph          <p></p>         (closing tag often unnecessary)
    '    align text         <p align=left|center|right></p>
    '    justify text       <p align=justify></p>
    '    line break         <br>            (a single carriage return)
    '    clear textwrap     <br clear=left|right|all>
    '    no break           <nobr></nobr>   (prevents line breaks)
    '    word break         <wbr>           (where to break a line if needed)
    '
    ' backgrounds and colors
    '    tiled bkground     <body background="url">
    '    watermark          <body bgproperties="fixed">
    '    bkground color     <body bgcolor="#$$$$$$"> (order is red/green/blue)
    '    text color         <body text="#$$$$$$">
    '
    ' miscellaneous
    '    url of this file   <base href="url">       (must be in header)
    '    base window name   <base target="***">     (must be in header)
    '
    '****************************************************************************
    #compile exe
    #register none
    #dim all
    '
    #include "win32api.inc"
    #include "commctrl.inc"
    '
    %idd_form1_labelcomboutput    = 100
    %idd_form1_labelrawtext       = 105
    %idd_form1_labelgraphic1      = 110
    %idd_form1_labelhtmltext      = 115
    %idd_form1_labelgraphwindow   = 120
    %idd_form1_butmakeoutput      = 125
    %idd_form1_butdisplcomboutp   = 130
    %idd_form1_buttonexit         = 140
    %idd_form1_texthtml           = 145
    %idd_form1_textraw            = 150
    %idd_form1_butprevfig         = 155
    %idd_form1_butnextfig         = 160
    %id_ocx                       = 165
    '
    global hform1&
    global gerror as long  ' stores the error variable
    global curgrano as long
    global totalgrano as long
    global currentpath as string
    global th$, tt$ ' th is for html-tagged text, tt is for plain text.
    global outmade&
    global memdc as long
    '
    global hocx as dword
    '
    %wm_forwardmsg = &h37f ' (895)
    
    ' the following 5 functions and subs are due to josé roca - thanks!
    ' *********************************************************************************************
      declare function atlaxwininit lib "atl.dll" alias "atlaxwininit" () as long
    ' *********************************************************************************************
      declare function atlaxwinterm () as long
    ' *********************************************************************************************
      function atlaxwinterm () as long
        unregisterclass ("atlaxwin", getmodulehandle(byval %null))
      end function
    ' *********************************************************************************************
    ' **********************************************************************************************
      declare function atlaxgetcontrol lib "atl.dll" alias "atlaxgetcontrol" _
         ( _
         byval hwnd as dword, _   ' [in] a handle to the window that is hosting the control.
         byref pp as dword _      ' [out] the iunknown of the control being hosted.
      ) as dword
    ' *********************************************************************************************
    
    ' *********************************************************************************************
    ' puts the address of an object in a variant and marks it as containing a dispatch variable
    ' *********************************************************************************************
      sub atlmakedispatch (byval lpobj as dword, byref vobj as variant)
         local lpvobj as variantapi ptr                 ' pointer to a variantapi structure
         let vobj = empty                               ' make sure is empty to avoid memory leaks
         lpvobj = varptr(vobj)                          ' get the variant address
         @lpvobj.vt = %vt_dispatch                      ' mark it as containing a dispatch variable
         @lpvobj.vd.pdispval = lpobj                    ' set the dispatch pointer address
      end sub
    ' *********************************************************************************************
    '***************************************************************************
    '***************************************************************************
    '***************************************************************************
    function gcolor(byval i as long) as long
      select case i
        ' common rgb colors:
        case 0 : function = &h000000???  '%black - same as rgb(0,0,0)
        case 1 : function = &hff0000???  '%blue
        case 2 : function = &h00ff00???  '%green
        case 3 : function = &hffff00???  '%cyan
        case 4 : function = &h0000ff???  '%red
        case 5 : function = &hff00ff???  '%magenta
        case 6 : function = &h00ffff???  '%yellow
        case 7 : function = &hffffff???  '%white - same as rgb(255,255,255)
        case 8 : function = &h808080???  '%gray
        case 9 : function = &hc0c0c0???  '%ltgray
        ' additional colors can be added e.g. using the rgb function,
        ' e.g. case 10: function = rgb(164,164,164)
        ' and so on.
        case else : function = &h000000???  '%black
      end select
    end function
    ' ------------------------------------------------
    function penstyle(byval i as long) as long
      select case i
        case 0 :   function = %ps_solid       '  _______
        case 1 :   function = %ps_dash        '  -------
        case 2 :   function = %ps_dot         '  .......
        case 3 :   function = %ps_dashdot     '  _._._._
        case 4 :   function = %ps_dashdotdot  '  _.._.._
        case else: function = %ps_solid
      end select
    end function
    ' ------------------------------------------------
    function makefont(byval fonttypesize as long,byval fontweight as long, _
        byval italic as long, byval underline as long,byval strikeout as long, _
        byval facename as string) as long
        local lffont as logfont  ' logfont structure
        local hdc&,logpixelsy&
        hdc = getdc(%hwnd_desktop)
        'retrieves device-specific information about the number
        'of pixels per logical inch along the screen height
        '(depends on screen resolution setting).
        'this is important to define appropriate font sizes.
        logpixelsy  = getdevicecaps(hdc, %logpixelsy)
        releasedc %hwnd_desktop, hdc
        'type logfont defines the attributes of a font.
        'see logfont in the win32 help file
        lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' better than: -(fonttypesize * logpixelsy) \ 72
                                                ' logical height of font
        lffont.lfwidth = 0                      ' logical average character width
        lffont.lfescapement = 0                 ' angle of escapement
        lffont.lforientation = 0                ' base-line orientation angle
        lffont.lfweight = fontweight            ' font weight
        lffont.lfitalic = italic                ' italic attribute flag    (0,1)
        lffont.lfunderline = underline          ' underline attribute flag (0,1)
        lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
        lffont.lfcharset = %ansi_charset        ' character set identifier
        lffont.lfoutprecision = %out_tt_precis  ' output precision
        lffont.lfclipprecision = %clip_default_precis  ' clipping precision
        lffont.lfquality = %default_quality     ' output quality
        lffont.lfpitchandfamily = %ff_dontcare  ' pitch and family
        lffont.lffacename = facename            ' typeface name string
        ' make font according to specifications
        function = createfontindirect (lffont)
    end function
    ' ------------------------------------------------
    sub makegraph(byval hdc as long,rct as rect,byref da() as single, _
                  byref gtext() as string, byval nm as long)
        local hpen as long
        local gtex as asciiz * 200
        local i as long
        local total as single
        local cumul as single
        local pi2 as single
        local pct as long, radius as long
        local recstart as long
        local rc as rect
        local hfont as long
        local xleft as long, ytop as long, xright as long, ybottom as long
        local xstart as long, ystart as long, xend as long, yend as long
        local xtext as long, ytext as long, korr as long
        local x1&,y1&, hbrush&
        x1&=rct.nright
        y1&=rct.nbottom
        fillrect hdc, rct, getstockobject(%white_brush)
        radius = y1&/3.6
        xleft  = x1&/2 - radius : xright =  x1&/2 + radius
        ytop   = y1&/2 - radius : ybottom = y1&/2 + radius
    
        total=0! : for i=1 to nm : total = total + da(i) : next
        local tc$ : tc$ = "
        for i=1 to nm
            tc = tc + left$(gtext(i)+space$(12),13)+using$("######.##   ##.##%",da(i),da(i)*100!/total)+$crlf
        next
        tc = tc + $crlf
        tt = tt + tc : th = th + tc
        '
        hfont = makefont(7,400,0,0,0,"arial") : selectobject hdc, hfont
        '
        pi2=8!*atn(1#) : cumul=0!
        korr=-9 ' empiric correction for height of characters. this may be improved.
        for i=1 to nm
          cumul = cumul + da(i) : pct=fix(100*da(i)/total+0.5)
          xtext = int(x1&/2+(radius-korr)*cos(pi2 * (cumul - da(i)/2) / total)+0.5)
          ytext = int(y1&/2-(radius-korr)*sin(pi2 * (cumul - da(i)/2) / total)+0.5)
          if cos(pi2 * (cumul - da(i)/2) / total) >= 0 then
            settextalign hdc,%ta_left ' text on right side of diagram
          else
            settextalign hdc,%ta_right ' text on left side of diagram
          end if
          gtex=gtext(i)+" ("+ltrim$(str$(pct))+"%)"
          textout hdc, xtext, ytext+korr, gtex, byval len(gtex)
        next
        deleteobject hfont
        '
        xstart=x1&/2+radius: ystart=y1&/2 ' select starting point for pie pieces
        cumul=0!
        for i=1 to nm
          cumul = cumul + da(i)
          xend  = int(x1&/2+radius*cos(pi2 * cumul / total)+0.5)
          yend  = int(y1&/2-radius*sin(pi2 * cumul / total)+0.5)
          hpen = createpen(penstyle(0), 0, gcolor(i)) : selectobject hdc, hpen
          hbrush = createsolidbrush(gcolor(i)) : selectobject hdc, hbrush
          pie hdc, xleft,ytop,xright,ybottom, xstart, ystart, xend, yend
          deleteobject hpen : deleteobject hbrush
          xstart=xend: ystart=yend
        next
    
    end sub
    '
    sub showenhmetafile
        local hemf&,hgr1&,hdc&,rc as rect
        hemf = getenhmetafile(bycopy currentpath+"demonstration_figure"+trim$(str$(curgrano))+".emf" )
        hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
        getclientrect hgr1, rc
        hdc = getdc(hgr1)
        call playenhmetafile (hdc, hemf, rc)
        ' copy graphics onto virtual window.
        bitblt memdc,0,0, rc.nright, rc.nbottom, hdc,0,0,%srccopy
        deleteenhmetafile hemf
        releasedc hgr1, hdc
        control set text hform1&, %idd_form1_labelgraphic1, "figure"+str$(curgrano)
    end sub
    '
    callback function form1_dlgproc
        '
        local oocx as dispatch
        local ohtml as dispatch
        local ocxname as asciiz * 255
        local punk as dword
        local vvar as variant
        local vres as variant
        '
        select case cbmsg
            case %wm_paint
                local hdc&, ps as paintstruct, rc as rect, hgr&
                hgr = getdlgitem(cbhndl, %idd_form1_labelgraphwindow)
                hdc = beginpaint(hgr, ps)
                getclientrect hgr, rc
                ' copy virtual window onto screen:
                bitblt hdc,0,0, rc.nright, rc.nbottom, memdc,0,0,%srccopy
                endpaint hgr, ps
            case %wm_destroy
                postquitmessage 0
            case %wm_command
                select case cbctl
                    case %idd_form1_buttonexit
                        if cbctlmsg = %bn_clicked or cbctlmsg = 1 then
                            dialog end cbhndl, 0
                        end if
                        '
                    case %idd_form1_butdisplcomboutp
                        if cbctlmsg=%bn_clicked then
                            ' get the handle of the control
                            control handle hform1&, %id_ocx to hocx
                            ' get the interface pointer of the webbrowser control
                            atlaxgetcontrol(hocx, punk)
                            ' make a dispatch variant from it to be able to use pb automation
                            atlmakedispatch(punk, vvar)
                            set oocx = vvar
                            vvar = currentpath+"iecontrdemon.html"
                            object call oocx.navigate(vvar)
                        end if
                        '
                    case %idd_form1_butnextfig
                        if cbctlmsg=%bn_clicked then
                            incr curgrano
                            if curgrano > totalgrano then curgrano = totalgrano : exit if
                            call showenhmetafile
                        end if
                        if curgrano > 1 then control enable hform1&, %idd_form1_butprevfig
                        if curgrano = totalgrano then
                            control disable hform1&, %idd_form1_butnextfig
                            control set focus hform1&, %idd_form1_butprevfig
                        end if
                        '
                    case %idd_form1_butprevfig
                        if cbctlmsg=%bn_clicked then
                            decr curgrano
                            if curgrano < 1 then curgrano = 1 : exit if
                            call showenhmetafile
                        end if
                        if curgrano < totalgrano then control enable hform1&, %idd_form1_butnextfig
                        if curgrano = 1 then
                            control disable hform1&, %idd_form1_butprevfig
                            control set focus hform1&, %idd_form1_butnextfig
                        end if
                    case else
                end select
            case else
        end select
    end function
    '
    function graphics(byval no as long,byref da() as single, _
                  byref gtext() as string, byval nm as long) as string
        local rct as rect, hgr1&
        static hdcref&,iwidthmm&,iheightmm&,iwidthpels&,iheightpels&
        local hdcemf&, hemf&, hdc&, i&, kk&
    
        ' get handle to graphics window
        hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
        '
        if no = 1 then ' do this only the first time and remember results.
            ' obtain a handle to a reference device context.
            hdcref = getdc(hform1&)
            '
            ' determine the full display dimensions.
            ' iwidthmm is the display width in millimeters.
            ' iheightmm is the display height in millimeters.
            ' iwidthpels is the display width in pixels.
            ' iheightpels is the display height in pixels
            iwidthmm = getdevicecaps(hdcref, %horzsize)
            iheightmm = getdevicecaps(hdcref, %vertsize)
            iwidthpels = getdevicecaps(hdcref, %horzres)
            iheightpels = getdevicecaps(hdcref, %vertres)
            '
            releasedc hform1&, hdcref
        end if
        '
        ' specify rectancle in 0.01 mm units for creation of metafile:
        '
        ' retrieve the coordinates of the client rectangle, in pixels.
        getclientrect hgr1,rct
        ' convert client coordinates to .01-mm units.
        ' use iwidthmm, iwidthpels, iheightmm, and
        ' iheightpels to determine the number of
        ' .01-millimeter units per pixel in the x- and y-directions.
        rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
        rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
        rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
        rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
        '
        ' create enhanced metafile
        hdcemf = createenhmetafile (%null, byval %null, rct, byval %null)
        ' get rectangle in pixels to display diagram
        getclientrect hgr1, rct
        call makegraph(hdcemf,rct,da(),gtext(),nm)
        hemf = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
        '
        if no = 1 then : curgrano = 1 : call showenhmetafile ' display first figure
        '
        local curpath as asciiz * 255, st$, pathandfile$, res&
        '
        getmodulefilename getmodulehandle("), curpath, 255  'get current path & exe
        '
        st$=curpath
        '
        currentpath=left$(st$,instr(-1, st$, any ":\/"))
        pathandfile$=currentpath+"demonstration_figure"+trim$(str$(no))+".emf"
        '
        res& = copyenhmetafile(hemf,bycopy pathandfile$) ' save to disk
        deleteenhmetafile hemf
        function = pathandfile$
    end function
    '
    callback function cbf_form1_butmakeoutput
        local i&, kk&, no&, graphfile$, txt$
        dim da(5) as single, gtext(5) as string, su(5) as single
        '
        if cbctlmsg=%bn_clicked then
            ' th is the html text string to be used for the ie control
            ' ***************************
            ' first the html text header:
            ' ***************************
            th = "<html>"+$crlf                         ' start of html-document
            th = th +"<head>"+$crlf                     ' start of header
            th = th +"<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">"+$crlf ' technical specification
            txt = "ie display and print demonstration"  ' title text
            th = th +"<title>"+txt+"</title>"+$crlf     ' title
            th = th +"</head>"+$crlf                    ' end of header
            th = th +"<body>"+$crlf                     ' start of body of content
            th = th +"<pre>"+$crlf                      ' preformatted text
            th = th +"<font face="courier new" color="#0000ff">"+$crlf ' font type and color        ' font color
            ' ****************************
            '
            ' tt is the plain text for a textbox
            tt = txt + $crlf + $crlf
            '
            th = th + txt + $crlf + $crlf
            '
            kk = 0
            ' data are completely imaginary
            ' they are only for illustration
            data food, house, clothes, leisure, travel
            for i=1 to 5 : incr kk : gtext(kk)=read$(kk) : next
            '
            data 452.92, 665.40, 87.76, 186.54
            ' expenses period 1
            for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
            no = 1
            tt = tt + "            period"+str$(no)+$crlf
            th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
            curgrano = 1
            graphfile$ = graphics(no, da(), gtext(), 4)
            ' include this graph in the html-tagged text file.
            tt = tt + "            figure"+str$(no)+$crlf+$crlf
            th = th + "            figure"+str$(no)
            th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
            '
            data 438.39, 666.24, 130.65, 230.54
            ' expenses period 2
            for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
            incr no
            tt = tt + "            period"+str$(no)+$crlf
            th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
            graphfile$ = graphics(no, da(), gtext(), 4)
            ' include this graph in the html-tagged text file.
            tt = tt + "            figure"+str$(no)+$crlf+$crlf
            th = th + "            figure"+str$(no)
            th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
            '
            data 410.67, 766.56, 200.65, 250.23, 698.54
            ' expenses period 3
            for i=1 to 5 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
            incr no
            tt = tt + "            period"+str$(no)+$crlf
            th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
            graphfile$ = graphics(no, da(), gtext(), 5)
            ' include this graph in the html-tagged text file.
            tt = tt + "            figure"+str$(no)+$crlf+$crlf
            th = th + "            figure"+str$(no)
            th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
            '
            data 502.37, 685.23, 41.65, 146.87
    '        ' expenses period 4
            for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
            incr no
            tt = tt + "            period"+str$(no)+$crlf
            th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
            graphfile$ = graphics(no, da(), gtext(), 4)
            ' include this graph in the html-tagged text file.
            tt = tt + "            figure"+str$(no)+$crlf+$crlf
            th = th + "            figure"+str$(no)
            th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
            '
            local total!
            for i = 1 to 5 : total = total + su(i) : next
            incr no
            tt = tt + "   results for all 4 periods"+$crlf
            th = th + "   <b><i><u>results for all 4 periods</b></i></u>"+$crlf
            graphfile$ = graphics(no, su(), gtext(), 5)
            ' include this graph in the html-tagged text file.
            tt = tt + "            figure"+str$(no)+$crlf+$crlf
            th = th + "            figure"+str$(no)
            th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
            '
            tt = tt + "           - - - - -"+$crlf
            th = th + "           - - - - -"+$crlf
            ' **********************
            ' end tags of html text:
            ' **********************
            th = th +"</font>"+$crlf
            th = th +"</pre>"+$crlf
            th = th +"</body>"+$crlf
            th = th +"</html>"+$crlf
            ' ***************************
            '
            totalgrano = no
            control set text hform1&, %idd_form1_texthtml, th
            control set text hform1&,  %idd_form1_textraw, tt
            '
            ' save html-string as a html-file
            local x& : x& = freefile
            open currentpath+"iecontrdemon.html" for binary as #x&
            put$ #x&, th
            seteof #x&  ' important if you use the same file name repeatedly with varying ourput.
            close #x&
            '
            control disable hform1&, %idd_form1_butprevfig
            control enable hform1&, %idd_form1_butnextfig
            control enable hform1&, %idd_form1_butdisplcomboutp
            outmade& = %true ' output flag set to true
        end if
    end function
    ' ------------------------------------------------
    function pbmain
        local oocx as dispatch
        local ocxname as asciiz * 255
        local umsg as tagmsg
        local st as asciiz * 100
        local hdc&, hbit&, rc as rect
        '
        ocxname = "shell.explorer"
        atlaxwininit   ' initializes atl
        '
        local style&, exstyle&
        style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center or %ws_clipchildren
        exstyle& = 0
        dialog new 0, "simple displaying and printing of text and graphics using the ie-control - vers. 2", 0, 0,  396,  264, style&, exstyle& to hform1&
        control add label, hform1&,  %idd_form1_labelcomboutput,  "combined text and graphics in ie-control", 206, 110, 182, 10, _
            %ws_child or %ws_visible or %ss_center
        control add label, hform1&,  %idd_form1_labelrawtext,  "plain text output", 6, 4, 190, 10, _
            %ws_child or %ws_visible or %ss_center
        control add label, hform1&,  %idd_form1_labelgraphic1,  ", 196, 28, 42, 10, _
            %ws_child or %ws_visible or %ss_center
        control add label, hform1&,  %idd_form1_labelhtmltext,  "text output with html-tags", 6, 122, 190, 10, _
            %ws_child or %ws_visible or %ss_center
        control add label, hform1&,  %idd_form1_labelgraphwindow,  ", 238, 6, 150, 98, _
            %ws_child or %ws_visible or %ws_border or %ss_whiteframe
        control add button, hform1&,  %idd_form1_butmakeoutput,  "&make output", 6, 246, 54, 14, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_butmakeoutput
        control add button, hform1&,  %idd_form1_butdisplcomboutp,  "&show combined output", 66, 246, 98, 14, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
        control add button, hform1&,  %idd_form1_buttonexit,  "e&xit", 170, 246, 26, 14, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
        control add textbox, hform1&,  %idd_form1_texthtml,  ", 6, 132, 190, 104, _
            %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
        control send hform1&,%idd_form1_texthtml,%wm_setfont,getstockobject(%ansi_fixed_font),%true
        control add textbox, hform1&,  %idd_form1_textraw,  ", 6, 14, 190, 104,_
            %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
        control send hform1&,%idd_form1_textraw,%wm_setfont,getstockobject(%ansi_fixed_font),%true
        control add button, hform1&,  %idd_form1_butprevfig,  "&prev.", 200, 42, 34, 14, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
        control add button, hform1&,  %idd_form1_butnextfig,  "&next", 200, 62, 34, 14, _
            %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
        control set color hform1&,%idd_form1_labelgraphwindow ,0,rgb(255,255,255)
        control set color hform1&,%idd_form1_textraw ,0,rgb(255,255,255)
        control set color hform1&,%idd_form1_texthtml ,0,rgb(255,255,255)
        '
        control add "atlaxwin", hform1&, %id_ocx, ocxname, 206, 120, 182, 140, %ws_visible or %ws_child or %ws_border
        '
        ' create a virtual window
        getclientrect getdlgitem(hform1&, %idd_form1_labelgraphwindow), rc
        hdc = getdc(getdlgitem(hform1&, %idd_form1_labelgraphwindow))
        memdc = createcompatibledc(hdc)
        hbit = createcompatiblebitmap(hdc, rc.nright, rc.nbottom)
        selectobject memdc, hbit
        selectobject memdc, getstockobject(%white_brush)
        patblt memdc, 0, 0, rc.nright, rc.nbottom, %patcopy
        '
        outmade& = %false ' start with output flag set to false.
        '
        dialog show modeless hform1&, call form1_dlgproc
        '
        while getmessage(umsg, %null, 0, 0)
            ' pass keyboard messages to the ancestor
            ' returns 0 if the message was not processed, nonzero if it was
            if sendmessage(hocx, %wm_forwardmsg, 0, varptr(umsg)) = 0 then
               if isdialogmessage(hform1&, umsg) = %false then
                  translatemessage umsg
                  dispatchmessage umsg
               end if
            end if
        wend
        '
        deletedc memdc
        deleteobject hbit
        '
        atlaxwinterm   ' uninitializes atl
        set oocx = nothing
        '
    end function


    [this message has been edited by erik christensen (edited may 01, 2005).]

    Comment


    • #3
      When I try to compile either of these programs I get a message
      that says "Cannot access compiler results." What might be the problem?

      ------------------

      Comment


      • #4
        martin,
        thanks!

        ------------------
        tom hanlin
        powerbasic staff

        Comment


        • #5
          ' simple displaying and printing of text and graphics using ie-control
          '¨- version 3
          nb: april 23, 2004: error corrected and code improved.
          no more resource leak - thanks to brad byrne.

          ' ================================================================================
          '
          ' comment please in the link referred to in the beginning of the first post.
          '
          ' this version saves all output - text and graphics - in one mht-file.
          '
          ' this change was made following a suggestion by semen matusovski, who pro-
          ' vided a very elegant code in this link:

          http://www.powerbasic.com/support/pb...ad.php?t=24201

          ' many thanks to semen matusovski for his help and inspiration.
          '
          ' for this version you need internet explorer version 6 installed
          ' on your computer. if the present code does not run satisfactorily it may
          ' help also to install atl version 2 or higher from one of the links
          ' referred to in the comments thread referred to above.

          ' using the ie-control you can display and print text and graphics output
          ' from your pb-programs in a simple and easy way. this program demonstrates
          ' how. the formating of the output is made using the standard html-tags.
          ' the most common of these tags are shown below.
          '
          ' the output from your program should be presented to the ie-control
          ' in condensed form as a single text-string with html-tags inserted where
          ' specific formatting features are needed. by letting your program insert
          ' the relevant html-tags, you can format your text as you wish. normally
          ' you would only need to use very few of them. it is important, however,
          ' that you supply the html-tagged text with a standardized starting and
          ' ending sequence like those shown in this program.
          '
          ' the mht(mhtlm-document)-file is organized in sections divided by a boundary
          ' sequence. the file structure follows the mime-version 1 protocol. the
          ' enhanced metafiles are not being saved separately to the disk, but
          ' maintained in memory as long as the program runs. they are, however, inclu-
          ' ded in the mht-file.
          '
          ' by clicking the right mouse button over the ie-window you can obtain a
          ' shortcut menu (slightly different if you click over a picture or over the
          ' text) by which you can copy to the clipboard or print the content via the
          ' printer dialog box.
          '
          ' good luck!
          '
          ' best regards,
          '
          ' erik christensen -------- e.chr@email.dk --------- april 9, 2004
          Code:
          '****************************************************************************
          ' some common html-tags:
          '****************************************************************************
          ' basic elements
          '    document type      <html></html>   (beginning and end of file)
          '    title              <title></title> (must be in header)
          '    header             <head></head>   (descriptive info, such as title)
          '    body               <body></body>   (bulk of the page)
          '
          ' structural definition
          '    heading            <h?></h?>       (the spec. defines 6 levels)
          '    align heading      <h? align=left|center|right></h?>
          '    code               <code></code>   (for source code listings)
          '    large font size    <big></big>
          '    small font size    <small></small>
          '
          ' presentation formatting
          '    bold               <b></b>
          '    italic             <i></i>
          '    underline          <u></u>
          '    subscript          <sub></sub>
          '    superscript        <sup></sup>
          '    preformatted       <pre></pre>             (display text spacing as-is)
          '    center             <center></center>       (for both text and images)
          '    font size          <font size=?></font>    (ranges from 1-7)
          '    change font size   <font size="+|-?"></font>
          '    font color         <font color="#$$$$$$"></font> (order is red/green/blue)
          '    select font        <font face="***"></font>
          '    point size         <font point-size=?></font>
          '    weight             <font weight=?></font>
          '    base font size     <basefont size=?>       (from 1-7; default is 3)
          '    marquee            <marquee></marquee>
          '
          ' positioning
          '    spacer             <spacer>
          '    size               <spacer size=?>
          '
          ' graphics
          '    display image      <img src="url">
          '    alignment          <img src="url" align=top|bottom|middle|left|right>
          '    alignment          <img src="url" align=texttop|absmiddle|baseline|absbottom>
          '    dimensions         <img src="url" width=? height=?>    (in pixels)
          '                       <img src="url" width=% height=%>    (as percentage of page width/height)
          '    border             <img src="url" border=?>            (in pixels)
          '    runaround space    <img src="url" hspace=? vspace=?>   (in pixels)
          '    embed object       <embed src="url">                   (insert object into page)
          '    object size        <embed src="url" width=? height=?>
          '
          ' dividers
          '    paragraph          <p></p>         (closing tag often unnecessary)
          '    align text         <p align=left|center|right></p>
          '    justify text       <p align=justify></p>
          '    line break         <br>            (a single carriage return)
          '    clear textwrap     <br clear=left|right|all>
          '    no break           <nobr></nobr>   (prevents line breaks)
          '    word break         <wbr>           (where to break a line if needed)
          '
          ' backgrounds and colors
          '    tiled bkground     <body background="url">
          '    watermark          <body bgproperties="fixed">
          '    bkground color     <body bgcolor="#$$$$$$"> (order is red/green/blue)
          '    text color         <body text="#$$$$$$">
          '
          ' miscellaneous
          '    url of this file   <base href="url">       (must be in header)
          '    base window name   <base target="***">     (must be in header)
          '
          '****************************************************************************
          #compile exe
          #register none
          #dim all
          '
          #include "win32api.inc"
          #include "commctrl.inc"
          '
          %idd_form1_labelcomboutput    = 100
          %idd_form1_labelrawtext       = 105
          %idd_form1_labelgraphic1      = 110
          %idd_form1_labelhtmltext      = 115
          %idd_form1_labelgraphwindow   = 120
          %idd_form1_butmakeoutput      = 125
          %idd_form1_butdisplcomboutp   = 130
          %idd_form1_buttonexit         = 140
          %idd_form1_texthtml           = 145
          %idd_form1_textraw            = 150
          %idd_form1_butprevfig         = 155
          %idd_form1_butnextfig         = 160
          %id_ocx                       = 165
          '
          global hform1&
          global gerror as long  ' stores the error variable
          global curgrano as long
          global totalgrano as long
          global currentpath as string
          global th$, tt$ ' th is for html-tagged text, tt is for plain text.
          global outmade&
          global hemf() as long
          global memdc as long
          '
          global hocx as dword
          '
          $boundary = "boundarybetweenfilesections"
          '
          %wm_forwardmsg = &h37f ' (895)
          
          ' the following 5 functions and subs are due to josé roca - thanks!
          ' *********************************************************************************************
            declare function atlaxwininit lib "atl.dll" alias "atlaxwininit" () as long
          ' *********************************************************************************************
            declare function atlaxwinterm () as long
          ' *********************************************************************************************
            function atlaxwinterm () as long
              unregisterclass ("atlaxwin", getmodulehandle(byval %null))
            end function
          ' *********************************************************************************************
          ' **********************************************************************************************
            declare function atlaxgetcontrol lib "atl.dll" alias "atlaxgetcontrol" _
               ( _
               byval hwnd as dword, _   ' [in] a handle to the window that is hosting the control.
               byref pp as dword _      ' [out] the iunknown of the control being hosted.
            ) as dword
          ' *********************************************************************************************
          
          ' *********************************************************************************************
          ' puts the address of an object in a variant and marks it as containing a dispatch variable
          ' *********************************************************************************************
            sub atlmakedispatch (byval lpobj as dword, byref vobj as variant)
               local lpvobj as variantapi ptr                 ' pointer to a variantapi structure
               let vobj = empty                               ' make sure is empty to avoid memory leaks
               lpvobj = varptr(vobj)                          ' get the variant address
               @lpvobj.vt = %vt_dispatch                      ' mark it as containing a dispatch variable
               @lpvobj.vd.pdispval = lpobj                    ' set the dispatch pointer address
            end sub
          ' *********************************************************************************************
          '***************************************************************************
          '***************************************************************************
          '***************************************************************************
          function gcolor(byval i as long) as long
            select case i
              ' common rgb colors:
              case 0 : function = &h000000???  '%black - same as rgb(0,0,0)
              case 1 : function = &hff0000???  '%blue
              case 2 : function = &h00ff00???  '%green
              case 3 : function = &hffff00???  '%cyan
              case 4 : function = &h0000ff???  '%red
              case 5 : function = &hff00ff???  '%magenta
              case 6 : function = &h00ffff???  '%yellow
              case 7 : function = &hffffff???  '%white - same as rgb(255,255,255)
              case 8 : function = &h808080???  '%gray
              case 9 : function = &hc0c0c0???  '%ltgray
              ' additional colors can be added e.g. using the rgb function,
              ' e.g. case 10: function = rgb(164,164,164)
              ' and so on.
              case else : function = &h000000???  '%black
            end select
          end function
          ' ------------------------------------------------
          function penstyle(byval i as long) as long
            select case i
              case 0 :   function = %ps_solid       '  _______
              case 1 :   function = %ps_dash        '  -------
              case 2 :   function = %ps_dot         '  .......
              case 3 :   function = %ps_dashdot     '  _._._._
              case 4 :   function = %ps_dashdotdot  '  _.._.._
              case else: function = %ps_solid
            end select
          end function
          ' ------------------------------------------------
          function makefont(byval fonttypesize as long,byval fontweight as long, _
              byval italic as long, byval underline as long,byval strikeout as long, _
              byval facename as string) as long
              local lffont as logfont  ' logfont structure
              local hdc&,logpixelsy&
              hdc = getdc(%hwnd_desktop)
              'retrieves device-specific information about the number
              'of pixels per logical inch along the screen height
              '(depends on screen resolution setting).
              'this is important to define appropriate font sizes.
              logpixelsy  = getdevicecaps(hdc, %logpixelsy)
              releasedc %hwnd_desktop, hdc
              'type logfont defines the attributes of a font.
              'see logfont in the win32 help file
              lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' better than: -(fonttypesize * logpixelsy) \ 72
                                                      ' logical height of font
              lffont.lfwidth = 0                      ' logical average character width
              lffont.lfescapement = 0                 ' angle of escapement
              lffont.lforientation = 0                ' base-line orientation angle
              lffont.lfweight = fontweight            ' font weight
              lffont.lfitalic = italic                ' italic attribute flag    (0,1)
              lffont.lfunderline = underline          ' underline attribute flag (0,1)
              lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
              lffont.lfcharset = %ansi_charset        ' character set identifier
              lffont.lfoutprecision = %out_tt_precis  ' output precision
              lffont.lfclipprecision = %clip_default_precis  ' clipping precision
              lffont.lfquality = %default_quality     ' output quality
              lffont.lfpitchandfamily = %ff_dontcare  ' pitch and family
              lffont.lffacename = facename            ' typeface name string
              ' make font according to specifications
              function = createfontindirect (lffont)
          end function
          ' ------------------------------------------------
          sub makegraph(byval hdc as long,rct as rect,byref da() as single, _
                        byref gtext() as string, byval nm as long)
              local hpen as long
              local gtex as asciiz * 200
              local i as long
              local total as single
              local cumul as single
              local pi2 as single
              local pct as long, radius as long
              local recstart as long
              local rc as rect
              local hfont as long
              local xleft as long, ytop as long, xright as long, ybottom as long
              local xstart as long, ystart as long, xend as long, yend as long
              local xtext as long, ytext as long, korr as long
              local x1&,y1&, hbrush&
              x1&=rct.nright
              y1&=rct.nbottom
              fillrect hdc, rct, getstockobject(%white_brush)
              radius = y1&/3.6
              xleft  = x1&/2 - radius : xright =  x1&/2 + radius
              ytop   = y1&/2 - radius : ybottom = y1&/2 + radius
          
              total=0! : for i=1 to nm : total = total + da(i) : next
              local tc$ : tc$ = "
              for i=1 to nm
                  tc = tc + left$(gtext(i)+space$(12),13)+using$("######.##   ##.##%",da(i),da(i)*100!/total)+$crlf
              next
              tc = tc + $crlf
              tt = tt + tc : th = th + tc
              '
              hfont = makefont(7,400,0,0,0,"arial") : selectobject hdc, hfont
              '
              pi2=8!*atn(1#) : cumul=0!
              korr=-9 ' empiric correction for height of characters. this may be improved.
              for i=1 to nm
                cumul = cumul + da(i) : pct=fix(100*da(i)/total+0.5)
                xtext = int(x1&/2+(radius-korr)*cos(pi2 * (cumul - da(i)/2) / total)+0.5)
                ytext = int(y1&/2-(radius-korr)*sin(pi2 * (cumul - da(i)/2) / total)+0.5)
                if cos(pi2 * (cumul - da(i)/2) / total) >= 0 then
                  settextalign hdc,%ta_left ' text on right side of diagram
                else
                  settextalign hdc,%ta_right ' text on left side of diagram
                end if
                gtex=gtext(i)+" ("+ltrim$(str$(pct))+"%)"
                textout hdc, xtext, ytext+korr, gtex, byval len(gtex)
              next
              deleteobject hfont
              '
              xstart=x1&/2+radius: ystart=y1&/2 ' select starting point for pie pieces
              cumul=0!
              for i=1 to nm
                cumul = cumul + da(i)
                xend  = int(x1&/2+radius*cos(pi2 * cumul / total)+0.5)
                yend  = int(y1&/2-radius*sin(pi2 * cumul / total)+0.5)
                hpen = createpen(penstyle(0), 0, gcolor(i)) : selectobject hdc, hpen
                hbrush = createsolidbrush(gcolor(i)) : selectobject hdc, hbrush
                pie hdc, xleft,ytop,xright,ybottom, xstart, ystart, xend, yend
                deleteobject hpen : deleteobject hbrush
                xstart=xend: ystart=yend
              next
          
          end sub
          '
          sub showenhmetafile
              local hgr1&,hdc&,rc as rect
              hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
              getclientrect hgr1, rc
              hdc = getdc(hgr1)
              call playenhmetafile (hdc, hemf(curgrano), rc)
              ' copy graphics onto virtual window.
              bitblt memdc,0,0, rc.nright, rc.nbottom, hdc,0,0,%srccopy
              releasedc hgr1, hdc
              control set text hform1&, %idd_form1_labelgraphic1, "figure"+str$(curgrano)
          end sub
          '
          callback function form1_dlgproc
              '
              local oocx as dispatch
              local ohtml as dispatch
              local ocxname as asciiz * 255
              local punk as dword
              local vvar as variant
              local vres as variant
              '
              select case cbmsg
                  case %wm_paint
                      local hdc&, ps as paintstruct, rc as rect, hgr&
                      hgr = getdlgitem(cbhndl, %idd_form1_labelgraphwindow)
                      hdc = beginpaint(hgr, ps)
                      getclientrect hgr, rc
                      ' copy virtual window onto screen:
                      bitblt hdc,0,0, rc.nright, rc.nbottom, memdc,0,0,%srccopy
                      endpaint hgr, ps
                  case %wm_destroy
                      postquitmessage 0
                  case %wm_command
                      select case cbctl
                          case %idd_form1_buttonexit
                              if cbctlmsg = %bn_clicked or cbctlmsg = 1 then
                                  dialog end cbhndl, 0
                              end if
                              '
                          case %idd_form1_butdisplcomboutp
                              if cbctlmsg=%bn_clicked then
                                  ' get the handle of the control
                                  control handle hform1&, %id_ocx to hocx
                                  ' get the interface pointer of the webbrowser control
                                  atlaxgetcontrol(hocx, punk)
                                  ' make a dispatch variant from it to be able to use pb automation
                                  atlmakedispatch(punk, vvar)
                                  set oocx = vvar
                                  vvar = currentpath+"iecontrdemon2.mht"
                                  object call oocx.navigate(vvar)
                              end if
                              '
                          case %idd_form1_butnextfig
                              if cbctlmsg=%bn_clicked then
                                  incr curgrano
                                  if curgrano > totalgrano then curgrano = totalgrano : exit if
                                  call showenhmetafile
                              end if
                              if curgrano > 1 then control enable hform1&, %idd_form1_butprevfig
                              if curgrano = totalgrano then
                                  control disable hform1&, %idd_form1_butnextfig
                                  control set focus hform1&, %idd_form1_butprevfig
                              end if
                              '
                          case %idd_form1_butprevfig
                              if cbctlmsg=%bn_clicked then
                                  decr curgrano
                                  if curgrano < 1 then curgrano = 1 : exit if
                                  call showenhmetafile
                              end if
                              if curgrano < totalgrano then control enable hform1&, %idd_form1_butnextfig
                              if curgrano = 1 then
                                  control disable hform1&, %idd_form1_butprevfig
                                  control set focus hform1&, %idd_form1_butnextfig
                              end if
                          case else
                      end select
                  case else
              end select
          end function
          '
          function graphics(byval no as long,byval headtxt as string, _
                            byref da() as single, byref gtext() as string, _
                            byval nm as long) as long
              local rct as rect, hgr1&
              static hdcref&,iwidthmm&,iheightmm&,iwidthpels&,iheightpels&
              local hdcemf&, i&, kk&
              '
              tt = tt + headtxt+$crlf
              th = th + "<b><i>"+headtxt+"</b></i>"+$crlf
              '
              ' get handle to graphics window
              hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
              '
              if no = 1 then ' do this only the first time and remember results.
                  ' obtain a handle to a reference device context.
                  hdcref = getdc(hform1&)
                  '
                  ' determine the full display dimensions.
                  ' iwidthmm is the display width in millimeters.
                  ' iheightmm is the display height in millimeters.
                  ' iwidthpels is the display width in pixels.
                  ' iheightpels is the display height in pixels
                  iwidthmm = getdevicecaps(hdcref, %horzsize)
                  iheightmm = getdevicecaps(hdcref, %vertsize)
                  iwidthpels = getdevicecaps(hdcref, %horzres)
                  iheightpels = getdevicecaps(hdcref, %vertres)
                  '
                  releasedc hform1&, hdcref
              end if
              '
              ' retrieve the coordinates of the client rectangle, in pixels.
              getclientrect hgr1,rct
              '
              ' specify rectancle in 0.01 mm units for creation of metafile:
              '
              ' convert client coordinates to .01-mm units.
              ' use iwidthmm, iwidthpels, iheightmm, and iheightpels to determine
              ' the number of .01-millimeter units per pixel in the x- and y-directions.
              rct.nleft = (rct.nleft * iwidthmm * 100)/iwidthpels
              rct.ntop = (rct.ntop * iheightmm * 100)/iheightpels
              rct.nright = (rct.nright * iwidthmm * 100)/iwidthpels
              rct.nbottom = (rct.nbottom * iheightmm * 100)/iheightpels
              '
              ' create enhanced metafile
              hdcemf = createenhmetafile (%null, byval %null, rct, byval %null)
              ' get rectangle in pixels to display diagram
              getclientrect hgr1, rct
              call makegraph(hdcemf,rct,da(),gtext(),nm)
              '
              redim preserve hemf(no)
              '
              hemf(no) = closeenhmetafile (hdcemf) ' get handle to enhanced metafile
              '
              if no = 1 then : curgrano = 1 : call showenhmetafile ' display first figure
              '
              tt = tt + "            figure"+str$(no)+$crlf+$crlf
              th = th + "            figure"+str$(no)
              th = th + $crlf + "<img src="file:///anyname"+trim$(str$(no))+".emf" border=1>" + $crlf + $crlf
              '
              function = hemf(no)
          end function
          '
          callback function cbf_form1_butmakeoutput
              local i&, j&, kk&, no&, graphfile$, txt$, szemf$, headertext$
              dim da(5) as single, gtext(5) as string, su(5) as single
              '
              if cbctlmsg=%bn_clicked then
                  ' th is the mhtml text string to be used for the ie control
                  ' ***************************
                  ' first the mhtml text header:
                  ' ***************************
                  th = "mime-version: 1.0" +$crlf
                  th = th + "content-type: multipart/related; boundary=" + $dq + $boundary + $dq + "; type="text/html"" + $crlf + $crlf
                  '      print #1, "
                  th = th + "--" + $boundary + $crlf
                  th = th + "content-type: text/html; charset="windows-1251"" + $crlf
                  th = th + "content-transfer-encoding: octet-stream" + $crlf + $crlf
          
                  th = th +"<html>"+$crlf                     ' start of html-document
                  th = th +"<head>"+$crlf                     ' start of header
              '    th = th +"<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">"+$crlf ' technical specification
                  txt = "ie display and print demonstration"  ' title text
                  th = th +"<title>"+txt+"</title>"+$crlf     ' title
                  th = th +"</head>"+$crlf                    ' end of header
                  th = th +"<body>"+$crlf                     ' start of body of content
                  th = th +"<pre>"+$crlf                      ' preformatted text
                  th = th +"<font face="courier new" color="#0000ff">"+$crlf ' font type and color        ' font color
                  ' ****************************
                  '
                  ' tt is the plain text for a textbox
                  tt = txt + $crlf + $crlf
                  '
                  th = th + txt + $crlf + $crlf
                  '
                  kk = 0
                  ' data are completely imaginary
                  ' they are only for illustration
                  data food, house, clothes, leisure, travel
                  for i=1 to 5 : incr kk : gtext(kk)=read$(kk) : next
                  '
                  ' expenses period 1
                  data 452.92, 665.40, 87.76, 186.54
                  for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                  no = 1 : headertext = "            period"+str$(no)
                  hemf(no) = graphics(no, headertext, da(), gtext(), 4)
                  '
                  ' expenses period 2
                  data 438.39, 666.24, 130.65, 230.54
                  for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                  incr no : headertext = "            period"+str$(no)
                  hemf(no) = graphics(no, headertext, da(), gtext(), 4)
                  '
                  ' expenses period 3
                  data 410.67, 766.56, 200.65, 250.23, 698.54
                  for i=1 to 5 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                  incr no : headertext = "            period"+str$(no)
                  hemf(no) = graphics(no, headertext, da(), gtext(), 5)
                  '
                  ' expenses period 4
                  data 502.37, 685.23, 41.65, 146.87
                  for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                  incr no : headertext = "            period"+str$(no)
                  hemf(no) = graphics(no, headertext, da(), gtext(), 4)
                  '
                  ' expenses for all 4 periods
                  local total!
                  for i = 1 to 5 : total = total + su(i) : next
                  incr no : headertext = "   results for all 4 periods"
                  hemf(no) = graphics(no, headertext, su(), gtext(), 5)
                  '
                  tt = tt + "           - - - - -"+$crlf
                  th = th + "           - - - - -"+$crlf
                  ' **********************
                  ' end tags of html text:
                  ' **********************
                  th = th +"</font>"+$crlf
                  th = th +"</pre>"+$crlf
                  th = th +"</body>"+$crlf
                  th = th +"</html>"+$crlf
                  ' ***************************
                  '
                  for i = 1 to no
                      th = th + "--"+$boundary + $crlf
                      th = th + "content-type: image/emf" + $crlf
                      th = th + "content-transfer-encoding: octet-stream" + $crlf
                      th = th + "content-location: file:///anyname"+trim$(str$(i))+".emf" + $crlf + $crlf
                      j = getenhmetafilebits(hemf(i), 0, byval 0)
                      szemf = space$(j)
                      getenhmetafilebits hemf(i), j, byval strptr(szemf)
                      th = th + szemf + $crlf + $crlf
                  next
                  '
                  th = th + "--"+$boundary + $crlf
                  '
                  totalgrano = no
                  '
                  ' save mhtml-string as a mht-file
                  local curpath as asciiz * 255, st$
                  getmodulefilename getmodulehandle("), curpath, 255  'get current path & exe
                  st$=curpath
                  currentpath=left$(st$,instr(-1, st$, any ":\/"))
                  '
                  local x& : x& = freefile
                  open currentpath+"iecontrdemon2.mht" for binary as #x&
                  put$ #x&, th
                  seteof #x&  ' important if you use the same file name repeatedly with varying ourput.
                  close #x&
                  '
                  local fs&
                  for i = 1 to len(th)
                      fs = asc(mid$(th,i,1))
                      ' replace asc-values below 32 (except cr and lf) with point sign: .
                      ' this enables display of full string in text-box.
                      if fs < 32 and (fs <> 10 and fs <> 13) then mid$(th,i) = "."
                  next
                  control set text hform1&, %idd_form1_texthtml, th
                  control set text hform1&,  %idd_form1_textraw, tt
                  '
                  control disable hform1&, %idd_form1_butprevfig
                  control enable hform1&, %idd_form1_butnextfig
                  control enable hform1&, %idd_form1_butdisplcomboutp
                  outmade& = %true ' output flag set to true
              end if
          end function
          ' ------------------------------------------------
          function pbmain
              local oocx as dispatch
              local ocxname as asciiz * 255
              local umsg as tagmsg
              local st as asciiz * 100, i&
              local hdc&, hbit&, rc as rect
              '
              ocxname = "shell.explorer"
              atlaxwininit   ' initializes atl
              '
              local style&, exstyle&
              style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center or %ws_clipchildren
              exstyle& = 0
              dialog new 0, "simple displaying and printing of text and graphics using the ie-control - vers. 3", 0, 0,  396,  264, style&, exstyle& to hform1&
              control add label, hform1&,  %idd_form1_labelcomboutput,  "combined text and graphics in ie-control", 206, 110, 182, 10, _
                  %ws_child or %ws_visible or %ss_center
              control add label, hform1&,  %idd_form1_labelrawtext,  "plain text output", 6, 4, 190, 10, _
                  %ws_child or %ws_visible or %ss_center
              control add label, hform1&,  %idd_form1_labelgraphic1,  ", 196, 28, 42, 10, _
                  %ws_child or %ws_visible or %ss_center
              control add label, hform1&,  %idd_form1_labelhtmltext,  "text output with mhtml-tags", 6, 122, 190, 10, _
                  %ws_child or %ws_visible or %ss_center
              control add label, hform1&,  %idd_form1_labelgraphwindow,  ", 238, 6, 150, 98, _
                  %ws_child or %ws_visible or %ws_border or %ss_whiteframe
              control add button, hform1&,  %idd_form1_butmakeoutput,  "&make output", 6, 246, 54, 14, _
                  %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_butmakeoutput
              control add button, hform1&,  %idd_form1_butdisplcomboutp,  "&show combined output", 66, 246, 98, 14, _
                  %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
              control add button, hform1&,  %idd_form1_buttonexit,  "e&xit", 170, 246, 26, 14, _
                  %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
              control add textbox, hform1&,  %idd_form1_texthtml,  ", 6, 132, 190, 104, _
                  %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
              control send hform1&,%idd_form1_texthtml,%wm_setfont,getstockobject(%ansi_fixed_font),%true
              control add textbox, hform1&,  %idd_form1_textraw,  ", 6, 14, 190, 104,_
                  %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
              control send hform1&,%idd_form1_textraw,%wm_setfont,getstockobject(%ansi_fixed_font),%true
              control add button, hform1&,  %idd_form1_butprevfig,  "&prev.", 200, 42, 34, 14, _
                  %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
              control add button, hform1&,  %idd_form1_butnextfig,  "&next", 200, 62, 34, 14, _
                  %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
              control set color hform1&,%idd_form1_labelgraphwindow ,0,rgb(255,255,255)
              control set color hform1&,%idd_form1_textraw ,0,rgb(255,255,255)
              control set color hform1&,%idd_form1_texthtml ,0,rgb(255,255,255)
              '
              control add "atlaxwin", hform1&, %id_ocx, ocxname, 206, 120, 182, 140, %ws_visible or %ws_child or %ws_border
              '
              ' create a virtual window
              getclientrect getdlgitem(hform1&, %idd_form1_labelgraphwindow), rc
              hdc = getdc(getdlgitem(hform1&, %idd_form1_labelgraphwindow))
              memdc = createcompatibledc(hdc)
              hbit = createcompatiblebitmap(hdc, rc.nright, rc.nbottom)
              selectobject memdc, hbit
              selectobject memdc, getstockobject(%white_brush)
              patblt memdc, 0, 0, rc.nright, rc.nbottom, %patcopy
              '
              outmade& = %false ' start with output flag set to false.
              '
              dialog show modeless hform1&, call form1_dlgproc
              '
              while getmessage(umsg, %null, 0, 0)
                  ' pass keyboard messages to the ancestor
                  ' returns 0 if the message was not processed, nonzero if it was
                  if sendmessage(hocx, %wm_forwardmsg, 0, varptr(umsg)) = 0 then
                     if isdialogmessage(hform1&, umsg) = %false then
                        translatemessage umsg
                        dispatchmessage umsg
                     end if
                  end if
              wend
              '
              for i = 1 to totalgrano
                  deleteenhmetafile hemf(i)
              next
              '
              deletedc memdc
              deleteobject hbit
              '
              atlaxwinterm   ' uninitializes atl
              set oocx = nothing
              '
          end function


          [this message has been edited by erik christensen (edited may 01, 2005).]

          Comment


          • #6
            ' simple displaying and printing of text and graphics using ie-control
            ' - version 4
            ' ================================================================================
            '
            ' comment please in the link referred to in the beginning of the first post.
            '
            ' this version corresponds to version 2 except that graphics figures are saved
            ' in bitmaps instead of enhanced metafiles.
            '
            ' many thanks to kev peel for his very fine function for saving bitmaps.
            ' his code is at this link:
            http://www.powerbasic.com/support/pb...ad.php?t=24207
            '
            ' for this version you need internet explorer version 6 installed
            ' on your computer. if the present code does not run satisfactorily it may
            ' help also to install atl version 2 or higher from one of the links
            ' referred to in the comments thread referred to above.

            ' using the ie-control you can display and print text and graphics output
            ' from your pb-programs in a simple and easy way. this program demonstrates
            ' how. the formating of the output is made using the standard html-tags.
            ' the most common of these tags are shown below.
            '
            ' the text output from your program should be presented to the ie-control
            ' in condensed form as a single text-string with html-tags inserted where
            ' specific formatting features are needed. by letting your program insert
            ' the relevant html-tags, you can format your text as you wish. normally
            ' you would only need to use very few of them. it is important, however,
            ' that you supply the html-tagged text with a standardized starting and
            ' ending sequence like those shown in this program.
            '
            ' graphics output from pb programs can be saved in bitmaps, which
            ' can be inserted anywhere in the output text-string by placing a html
            ' image tag with an url referring to the graphics file in question. by the
            ' way, image files in other formats can also be inserted. it will save space
            ' to compress the files to jpeg format before saving to disk. to do this you
            ' need to involve a special program e.g. gdiplus (gdi+) which can be
            ' downloaded from microsoft. josé roca have posted a code demonstrating use
            ' of this program:
            http://www.powerbasic.com/support/pb...ad.php?t=23625
            '
            ' by clicking the right mouse button over the ie-control you can obtain a
            ' shortcut menu (slightly different if you click over a picture or over the
            ' text) by which you can copy to the clipboard or print the content via the
            ' printer dialog box.
            '
            ' good luck!
            '
            ' best regards,
            '
            ' erik christensen -------- e.chr@email.dk --------- may 5, 2004
            Code:
            '****************************************************************************
            ' some common html-tags:
            '****************************************************************************
            ' basic elements
            '    document type      <html></html>   (beginning and end of file)
            '    title              <title></title> (must be in header)
            '    header             <head></head>   (descriptive info, such as title)
            '    body               <body></body>   (bulk of the page)
            '
            ' structural definition
            '    heading            <h?></h?>       (the spec. defines 6 levels)
            '    align heading      <h? align=left|center|right></h?>
            '    code               <code></code>   (for source code listings)
            '    large font size    <big></big>
            '    small font size    <small></small>
            '
            ' presentation formatting
            '    bold               <b></b>
            '    italic             <i></i>
            '    underline          <u></u>
            '    subscript          <sub></sub>
            '    superscript        <sup></sup>
            '    preformatted       <pre></pre>             (display text spacing as-is)
            '    center             <center></center>       (for both text and images)
            '    font size          <font size=?></font>    (ranges from 1-7)
            '    change font size   <font size="+|-?"></font>
            '    font color         <font color="#$$$$$$"></font> (order is red/green/blue)
            '    select font        <font face="***"></font>
            '    point size         <font point-size=?></font>
            '    weight             <font weight=?></font>
            '    base font size     <basefont size=?>       (from 1-7; default is 3)
            '    marquee            <marquee></marquee>
            '
            ' positioning
            '    spacer             <spacer>
            '    size               <spacer size=?>
            '
            ' graphics
            '    display image      <img src="url">
            '    alignment          <img src="url" align=top|bottom|middle|left|right>
            '    alignment          <img src="url" align=texttop|absmiddle|baseline|absbottom>
            '    dimensions         <img src="url" width=? height=?>    (in pixels)
            '                       <img src="url" width=% height=%>    (as percentage of page width/height)
            '    border             <img src="url" border=?>            (in pixels)
            '    runaround space    <img src="url" hspace=? vspace=?>   (in pixels)
            '    embed object       <embed src="url">                   (insert object into page)
            '    object size        <embed src="url" width=? height=?>
            '
            ' dividers
            '    paragraph          <p></p>         (closing tag often unnecessary)
            '    align text         <p align=left|center|right></p>
            '    justify text       <p align=justify></p>
            '    line break         <br>            (a single carriage return)
            '    clear textwrap     <br clear=left|right|all>
            '    no break           <nobr></nobr>   (prevents line breaks)
            '    word break         <wbr>           (where to break a line if needed)
            '
            ' backgrounds and colors
            '    tiled bkground     <body background="url">
            '    watermark          <body bgproperties="fixed">
            '    bkground color     <body bgcolor="#$$$$$$"> (order is red/green/blue)
            '    text color         <body text="#$$$$$$">
            '
            ' miscellaneous
            '    url of this file   <base href="url">       (must be in header)
            '    base window name   <base target="***">     (must be in header)
            '
            '****************************************************************************
            #compile exe
            #register none
            #dim all
            '
            #include "win32api.inc"
            #include "commctrl.inc"
            '
            %idd_form1_labelcomboutput    = 100
            %idd_form1_labelrawtext       = 105
            %idd_form1_labelgraphic1      = 110
            %idd_form1_labelhtmltext      = 115
            %idd_form1_labelgraphwindow   = 120
            %idd_form1_butmakeoutput      = 125
            %idd_form1_butdisplcomboutp   = 130
            %idd_form1_buttonexit         = 140
            %idd_form1_texthtml           = 145
            %idd_form1_textraw            = 150
            %idd_form1_butprevfig         = 155
            %idd_form1_butnextfig         = 160
            %id_ocx                       = 165
            '
            global hform1&
            global gerror as long  ' stores the error variable
            global curgrano as long
            global totalgrano as long
            global currentpath as string
            global th$, tt$ ' th is for html-tagged text, tt is for plain text.
            global outmade&
            global memdc as long
            '
            global hocx as dword
            '
            %wm_forwardmsg = &h37f ' (895)
            
            ' the following 5 functions and subs are due to josé roca - thanks!
            ' *********************************************************************************************
              declare function atlaxwininit lib "atl.dll" alias "atlaxwininit" () as long
            ' *********************************************************************************************
              declare function atlaxwinterm () as long
            ' *********************************************************************************************
              function atlaxwinterm () as long
                unregisterclass ("atlaxwin", getmodulehandle(byval %null))
              end function
            ' *********************************************************************************************
            ' **********************************************************************************************
              declare function atlaxgetcontrol lib "atl.dll" alias "atlaxgetcontrol" _
                 ( _
                 byval hwnd as dword, _   ' [in] a handle to the window that is hosting the control.
                 byref pp as dword _      ' [out] the iunknown of the control being hosted.
              ) as dword
            ' *********************************************************************************************
            
            ' *********************************************************************************************
            ' puts the address of an object in a variant and marks it as containing a dispatch variable
            ' *********************************************************************************************
              sub atlmakedispatch (byval lpobj as dword, byref vobj as variant)
                 local lpvobj as variantapi ptr                 ' pointer to a variantapi structure
                 let vobj = empty                               ' make sure is empty to avoid memory leaks
                 lpvobj = varptr(vobj)                          ' get the variant address
                 @lpvobj.vt = %vt_dispatch                      ' mark it as containing a dispatch variable
                 @lpvobj.vd.pdispval = lpobj                    ' set the dispatch pointer address
              end sub
            ' *********************************************************************************************
            '***************************************************************************
            '***************************************************************************
            '***************************************************************************
            function gcolor(byval i as long) as long
              select case i
                ' common rgb colors:
                case 0 : function = &h000000???  '%black - same as rgb(0,0,0)
                case 1 : function = &hff0000???  '%blue
                case 2 : function = &h00ff00???  '%green
                case 3 : function = &hffff00???  '%cyan
                case 4 : function = &h0000ff???  '%red
                case 5 : function = &hff00ff???  '%magenta
                case 6 : function = &h00ffff???  '%yellow
                case 7 : function = &hffffff???  '%white - same as rgb(255,255,255)
                case 8 : function = &h808080???  '%gray
                case 9 : function = &hc0c0c0???  '%ltgray
                ' additional colors can be added e.g. using the rgb function,
                ' e.g. case 10: function = rgb(164,164,164)
                ' and so on.
                case else : function = &h000000???  '%black
              end select
            end function
            ' ------------------------------------------------
            function penstyle(byval i as long) as long
              select case i
                case 0 :   function = %ps_solid       '  _______
                case 1 :   function = %ps_dash        '  -------
                case 2 :   function = %ps_dot         '  .......
                case 3 :   function = %ps_dashdot     '  _._._._
                case 4 :   function = %ps_dashdotdot  '  _.._.._
                case else: function = %ps_solid
              end select
            end function
            ' ------------------------------------------------
            function makefont(byval fonttypesize as long,byval fontweight as long, _
                byval italic as long, byval underline as long,byval strikeout as long, _
                byval facename as string) as long
                local lffont as logfont  ' logfont structure
                local hdc&,logpixelsy&
                hdc = getdc(%hwnd_desktop)
                'retrieves device-specific information about the number
                'of pixels per logical inch along the screen height
                '(depends on screen resolution setting).
                'this is important to define appropriate font sizes.
                logpixelsy  = getdevicecaps(hdc, %logpixelsy)
                releasedc %hwnd_desktop, hdc
                'type logfont defines the attributes of a font.
                'see logfont in the win32 help file
                lffont.lfheight = -muldiv(fonttypesize,logpixelsy,72) ' better than: -(fonttypesize * logpixelsy) \ 72
                                                        ' logical height of font
                lffont.lfwidth = 0                      ' logical average character width
                lffont.lfescapement = 0                 ' angle of escapement
                lffont.lforientation = 0                ' base-line orientation angle
                lffont.lfweight = fontweight            ' font weight
                lffont.lfitalic = italic                ' italic attribute flag    (0,1)
                lffont.lfunderline = underline          ' underline attribute flag (0,1)
                lffont.lfstrikeout = strikeout          ' strikeout attribute flag (0,1)
                lffont.lfcharset = %ansi_charset        ' character set identifier
                lffont.lfoutprecision = %out_tt_precis  ' output precision
                lffont.lfclipprecision = %clip_default_precis  ' clipping precision
                lffont.lfquality = %default_quality     ' output quality
                lffont.lfpitchandfamily = %ff_dontcare  ' pitch and family
                lffont.lffacename = facename            ' typeface name string
                ' make font according to specifications
                function = createfontindirect (lffont)
            end function
            ' ------------------------------------------------
            sub makegraph(byval hdc as long,rct as rect,byref da() as single, _
                          byref gtext() as string, byval nm as long)
                local hpen as long
                local gtex as asciiz * 200
                local i as long
                local total as single
                local cumul as single
                local pi2 as single
                local pct as long, radius as long
                local recstart as long
                local rc as rect
                local hfont as long
                local xleft as long, ytop as long, xright as long, ybottom as long
                local xstart as long, ystart as long, xend as long, yend as long
                local xtext as long, ytext as long, korr as long
                local x1&,y1&, hbrush&
                x1&=rct.nright
                y1&=rct.nbottom
                fillrect hdc, rct, getstockobject(%white_brush)
                radius = y1&/3.6
                xleft  = x1&/2 - radius : xright =  x1&/2 + radius
                ytop   = y1&/2 - radius : ybottom = y1&/2 + radius
            
                total=0! : for i=1 to nm : total = total + da(i) : next
                local tc$ : tc$ = "
                for i=1 to nm
                    tc = tc + left$(gtext(i)+space$(12),13)+using$("######.##   ##.##%",da(i),da(i)*100!/total)+$crlf
                next
                tc = tc + $crlf
                tt = tt + tc : th = th + tc
                '
                hfont = makefont(7,400,0,0,0,"arial") : selectobject hdc, hfont
                '
                pi2=8!*atn(1#) : cumul=0!
                korr=-9 ' empiric correction for height of characters. this may be improved.
                for i=1 to nm
                  cumul = cumul + da(i) : pct=fix(100*da(i)/total+0.5)
                  xtext = int(x1&/2+(radius-korr)*cos(pi2 * (cumul - da(i)/2) / total)+0.5)
                  ytext = int(y1&/2-(radius-korr)*sin(pi2 * (cumul - da(i)/2) / total)+0.5)
                  if cos(pi2 * (cumul - da(i)/2) / total) >= 0 then
                    settextalign hdc,%ta_left ' text on right side of diagram
                  else
                    settextalign hdc,%ta_right ' text on left side of diagram
                  end if
                  gtex=gtext(i)+" ("+ltrim$(str$(pct))+"%)"
                  textout hdc, xtext, ytext+korr, gtex, byval len(gtex)
                next
                deleteobject hfont
                '
                xstart=x1&/2+radius: ystart=y1&/2 ' select starting point for pie pieces
                cumul=0!
                for i=1 to nm
                  cumul = cumul + da(i)
                  xend  = int(x1&/2+radius*cos(pi2 * cumul / total)+0.5)
                  yend  = int(y1&/2-radius*sin(pi2 * cumul / total)+0.5)
                  hpen = createpen(penstyle(0), 0, gcolor(i)) : selectobject hdc, hpen
                  hbrush = createsolidbrush(gcolor(i)) : selectobject hdc, hbrush
                  pie hdc, xleft,ytop,xright,ybottom, xstart, ystart, xend, yend
                  deleteobject hpen : deleteobject hbrush
                  xstart=xend: ystart=yend
                next
            
            end sub
            '
            sub showgraphics
                local hgr1&,hdc&
                local rc as rect, hbmp as dword
                hbmp = loadimage(0, currentpath+"demonstration_figure"+trim$(str$(curgrano))+".bmp", %image_bitmap, 0, 0, %lr_loadfromfile)
                control send hform1&, %idd_form1_labelgraphwindow, %stm_setimage, %image_bitmap, hbmp
                hgr1& = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
                getclientrect hgr1, rc
                hdc = getdc(hgr1)
                ' copy graphics onto virtual window.
                bitblt memdc,0,0, rc.nright, rc.nbottom, hdc,0,0,%srccopy
                releasedc hgr1, hdc
                control set text hform1&, %idd_form1_labelgraphic1, "figure"+str$(curgrano)
            end sub
            '
            callback function form1_dlgproc
                '
                local oocx as dispatch
                local ohtml as dispatch
                local ocxname as asciiz * 255
                local punk as dword
                local vvar as variant
                local vres as variant
                '
                select case cbmsg
                    case %wm_paint
                        local hdc&, ps as paintstruct, rc as rect, hgr&
                        hgr = getdlgitem(cbhndl, %idd_form1_labelgraphwindow)
                        hdc = beginpaint(hgr, ps)
                        getclientrect hgr, rc
                        ' copy virtual window onto screen:
                        bitblt hdc,0,0, rc.nright, rc.nbottom, memdc,0,0,%srccopy
                        endpaint hgr, ps
                    case %wm_destroy
                        postquitmessage 0
                    case %wm_command
                        select case cbctl
                            case %idd_form1_buttonexit
                                if cbctlmsg = %bn_clicked or cbctlmsg = 1 then
                                    dialog end cbhndl, 0
                                end if
                                '
                            case %idd_form1_butdisplcomboutp
                                if cbctlmsg=%bn_clicked then
                                    ' get the handle of the control
                                    control handle hform1&, %id_ocx to hocx
                                    ' get the interface pointer of the webbrowser control
                                    atlaxgetcontrol(hocx, punk)
                                    ' make a dispatch variant from it to be able to use pb automation
                                    atlmakedispatch(punk, vvar)
                                    set oocx = vvar
                                    vvar = currentpath+"iecontrdemon4.html"
                                    object call oocx.navigate(vvar)
                                end if
                                '
                            case %idd_form1_butnextfig
                                if cbctlmsg=%bn_clicked then
                                    incr curgrano
                                    if curgrano > totalgrano then curgrano = totalgrano : exit if
                                    call showgraphics
                                end if
                                if curgrano > 1 then control enable hform1&, %idd_form1_butprevfig
                                if curgrano = totalgrano then
                                    control disable hform1&, %idd_form1_butnextfig
                                    control set focus hform1&, %idd_form1_butprevfig
                                end if
                                '
                            case %idd_form1_butprevfig
                                if cbctlmsg=%bn_clicked then
                                    decr curgrano
                                    if curgrano < 1 then curgrano = 1 : exit if
                                    call showgraphics
                                end if
                                if curgrano < totalgrano then control enable hform1&, %idd_form1_butnextfig
                                if curgrano = 1 then
                                    control disable hform1&, %idd_form1_butprevfig
                                    control set focus hform1&, %idd_form1_butnextfig
                                end if
                            case else
                        end select
                    case else
                end select
            end function
            '
            function savegraphicsasbitmap(byval hparam as dword, byval sbmpfile as string) as long
              '------------------------------------------------------------------------------
              ' saves a screen area to a bitmap file
              '
              ' hparam is a pointer to a rect area to capture. can also be a window handle.
              ' sbmpfile is the file name to save to.
              '
              ' saves in 32 bits per pixel (bpp)
              '------------------------------------------------------------------------------
              ' this function is a renamed and slightly modified version of kev peel's code - thank you!
              local hdc as dword, hmemdc as dword, hmembmp as dword, rc as rect
              local bm as bitmap, bmi as bitmapinfo
              local bmpfilehdr as bitmapfileheader, dwwidthbytes as dword, hfile as long
            
              ' must have file name...
              if len(sbmpfile) = 0 then exit function
            
              ' default to desktop window...
              if iswindow(hparam) then
            
                 ' obtain entire window area...
                 getwindowrect hparam, rc
              else
                 if istrue isbadreadptr(hparam, sizeof(rect)) then
                    ' if rect pointer is invalid (and no window specified), get desktop size...
                    setrect rc, 0, 0, getsystemmetrics(%sm_cxscreen), getsystemmetrics(%sm_cyscreen)
                 else
                    ' get specified desktop area...
                    poke$ varptr(rc), peek$(hparam, sizeof(rect))
                 end if
              end if
            
              ' create hidden dc and copy window contents...
              hdc = createdc("display", byval %null, byval %null, byval %null)
              hmemdc = createcompatibledc(hdc)
              bmi.bmiheader.bisize = sizeof(bmi.bmiheader)
              bmi.bmiheader.biwidth = (rc.nright - rc.nleft)
              bmi.bmiheader.biheight = (rc.nbottom - rc.ntop)
            
              ' four byte alignment...
              dwwidthbytes = bmi.bmiheader.biwidth + (bmi.bmiheader.biwidth mod 4)
            
              bmi.bmiheader.biplanes = 1
              bmi.bmiheader.bibitcount = 32
              bmi.bmiheader.bicompression = %bi_rgb
              hmembmp = createdibsection(hmemdc, bmi, %dib_rgb_colors, %null, 0, 0)
            
              selectobject hmemdc, hmembmp
              getobject hmembmp, sizeof(bm), bm
              bitblt hmemdc, 0, 0, bm.bmwidth, bm.bmheight, hdc, rc.nleft, rc.ntop, %srccopy
            
              bmpfilehdr.bftype = cvi("bm")
              bmpfilehdr.bfoffbits = 54
            
              bmpfilehdr.bfsize = sizeof(bmpfilehdr) + (dwwidthbytes * bm.bmheight)
            
              ' write to disk...
              hfile = freefile
              open sbmpfile for output as #hfile
              print #hfile, bmpfilehdr; bmi.bmiheader; peek$(bm.bmbits, bm.bmwidthbytes * bm.bmheight);
              close hfile
              if err = 0 then function = %true
            
              ' clean up and exit...
              deletedc hdc
              deletedc hmemdc
              deleteobject hmembmp
            
            end function
            '
            function graphics(byval no as long,byref da() as single, _
                          byref gtext() as string, byval nm as long) as string
                local rct as rect, hgr1 as dword
                local hdc&
                ' get handle to graphics window
                hgr1 = getdlgitem(hform1&, %idd_form1_labelgraphwindow)
                ' get rectangle in pixels to display diagram
                getclientrect hgr1, rct
                hdc = getdc(hgr1)
                '
                if no = 1 then : curgrano = 1
                call makegraph(hdc,rct,da(),gtext(),nm)
                '
                local curpath as asciiz * 255, st$, pathandfile$, res&
                '
                getmodulefilename getmodulehandle("), curpath, 255  'get current path & exe
                '
                st$=curpath
                '
                currentpath=left$(st$,instr(-1, st$, any ":\/"))
                pathandfile$=currentpath+"demonstration_figure"+trim$(str$(no))+".bmp"
                '
                call savegraphicsasbitmap(hgr1, pathandfile$)
                '
                function = pathandfile$
            end function
            '
            callback function cbf_form1_butmakeoutput
                local i&, kk&, no&, graphfile$, txt$
                dim da(5) as single, gtext(5) as string, su(5) as single
                '
                if cbctlmsg=%bn_clicked then
                    ' th is the html text string to be used for the ie control
                    ' ***************************
                    ' first the html text header:
                    ' ***************************
                    th = "<html>"+$crlf                         ' start of html-document
                    th = th +"<head>"+$crlf                     ' start of header
                    th = th +"<meta http-equiv="content-type" content="text/html; charset=iso-8859-1">"+$crlf ' technical specification
                    txt = "ie display and print demonstration"  ' title text
                    th = th +"<title>"+txt+"</title>"+$crlf     ' title
                    th = th +"</head>"+$crlf                    ' end of header
                    th = th +"<body>"+$crlf                     ' start of body of content
                    th = th +"<pre>"+$crlf                      ' preformatted text
                    th = th +"<font face="courier new" color="#0000ff">"+$crlf ' font type and color
                    ' ****************************
                    '
                    ' tt is the plain text for a textbox
                    tt = txt + $crlf + $crlf
                    '
                    th = th + txt + $crlf + $crlf
                    '
                    kk = 0
                    ' data are completely imaginary
                    ' they are only for illustration
                    data food, house, clothes, leisure, travel
                    for i=1 to 5 : incr kk : gtext(kk)=read$(kk) : next
                    '
                    data 452.92, 665.40, 87.76, 186.54
                    ' expenses period 1
                    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                    no = 1
                    tt = tt + "            period"+str$(no)+$crlf
                    th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
                    curgrano = 1
                    graphfile$ = graphics(no, da(), gtext(), 4)
                    ' include this graph in the html-tagged text file.
                    tt = tt + "            figure"+str$(no)+$crlf+$crlf
                    th = th + "            figure"+str$(no)
                    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
                    '
                    data 438.39, 666.24, 130.65, 230.54
                    ' expenses period 2
                    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                    incr no
                    tt = tt + "            period"+str$(no)+$crlf
                    th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
                    graphfile$ = graphics(no, da(), gtext(), 4)
                    ' include this graph in the html-tagged text file.
                    tt = tt + "            figure"+str$(no)+$crlf+$crlf
                    th = th + "            figure"+str$(no)
                    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
                    '
                    data 410.67, 766.56, 200.65, 250.23, 698.54
                    ' expenses period 3
                    for i=1 to 5 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                    incr no
                    tt = tt + "            period"+str$(no)+$crlf
                    th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
                    graphfile$ = graphics(no, da(), gtext(), 5)
                    ' include this graph in the html-tagged text file.
                    tt = tt + "            figure"+str$(no)+$crlf+$crlf
                    th = th + "            figure"+str$(no)
                    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
                    '
                    data 502.37, 685.23, 41.65, 146.87
            '        ' expenses period 4
                    for i=1 to 4 : incr kk : da(i) = val(read$(kk)) : su(i) = su(i) + da(i) : next
                    incr no
                    tt = tt + "            period"+str$(no)+$crlf
                    th = th + "            <b><i><u>period"+str$(no)+"</b></i></u>"+$crlf
                    graphfile$ = graphics(no, da(), gtext(), 4)
                    ' include this graph in the html-tagged text file.
                    tt = tt + "            figure"+str$(no)+$crlf+$crlf
                    th = th + "            figure"+str$(no)
                    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
                    '
                    local total!
                    for i = 1 to 5 : total = total + su(i) : next
                    incr no
                    tt = tt + "   results for all 4 periods"+$crlf
                    th = th + "   <b><i><u>results for all 4 periods</b></i></u>"+$crlf
                    graphfile$ = graphics(no, su(), gtext(), 5)
                    ' include this graph in the html-tagged text file.
                    tt = tt + "            figure"+str$(no)+$crlf+$crlf
                    th = th + "            figure"+str$(no)
                    th = th + $crlf + "<img src=""+graphfile$+"" border=1>" + $crlf + $crlf
                    '
                    tt = tt + "           - - - - -"+$crlf
                    th = th + "           - - - - -"+$crlf
                    ' **********************
                    ' end tags of html text:
                    ' **********************
                    th = th +"</font>"+$crlf
                    th = th +"</pre>"+$crlf
                    th = th +"</body>"+$crlf
                    th = th +"</html>"+$crlf
                    ' ***************************
                    '
                    totalgrano = no
                    control set text hform1&, %idd_form1_texthtml, th
                    control set text hform1&,  %idd_form1_textraw, tt
                    '
                    ' save html-string as a html-file
                    local x& : x& = freefile
                    open currentpath+"iecontrdemon4.html" for binary as #x&
                    put$ #x&, th
                    seteof #x&  ' important if you use the same file name repeatedly with varying ourput.
                    close #x&
                    '
                    control disable hform1&, %idd_form1_butprevfig
                    control enable hform1&, %idd_form1_butnextfig
                    control enable hform1&, %idd_form1_butdisplcomboutp
                    outmade& = %true  ' output flag set to true
                    call showgraphics ' go back to figure 1
                end if
            end function
            ' ------------------------------------------------
            function pbmain
                local oocx as dispatch
                local ocxname as asciiz * 255
                local umsg as tagmsg
                local st as asciiz * 100
                local hdc&, hbit&, rc as rect
                '
                ocxname = "shell.explorer"
                atlaxwininit   ' initializes atl
                '
                local style&, exstyle&
                style& = %ws_popup or %ds_modalframe or %ws_caption or %ws_minimizebox or %ws_sysmenu or %ds_center or %ws_clipchildren
                exstyle& = 0
                dialog new 0, "simple displaying and printing of text and graphics using the ie-control - vers. 4", 0, 0,  396,  264, style&, exstyle& to hform1&
                control add label, hform1&,  %idd_form1_labelcomboutput,  "combined text and graphics in ie-control", 206, 110, 182, 10, _
                    %ws_child or %ws_visible or %ss_center
                control add label, hform1&,  %idd_form1_labelrawtext,  "plain text output", 6, 4, 190, 10, _
                    %ws_child or %ws_visible or %ss_center
                control add label, hform1&,  %idd_form1_labelgraphic1,  ", 196, 28, 42, 10, _
                    %ws_child or %ws_visible or %ss_center
                control add label, hform1&,  %idd_form1_labelhtmltext,  "text output with html-tags", 6, 122, 190, 10, _
                    %ws_child or %ws_visible or %ss_center
                control add label, hform1&,  %idd_form1_labelgraphwindow,  ", 238, 6, 150, 98, _
                    %ws_child or %ws_visible or %ss_bitmap  ' or %ws_visible or %ss_whiteframe
                control add button, hform1&,  %idd_form1_butmakeoutput,  "&make output", 6, 246, 54, 14, _
                    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop call cbf_form1_butmakeoutput
                control add button, hform1&,  %idd_form1_butdisplcomboutp,  "&show combined output", 66, 246, 98, 14, _
                    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
                control add button, hform1&,  %idd_form1_buttonexit,  "e&xit", 170, 246, 26, 14, _
                    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop
                control add textbox, hform1&,  %idd_form1_texthtml,  ", 6, 132, 190, 104, _
                    %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
                control send hform1&,%idd_form1_texthtml,%wm_setfont,getstockobject(%ansi_fixed_font),%true
                control add textbox, hform1&,  %idd_form1_textraw,  ", 6, 14, 190, 104,_
                    %ws_child or %ws_visible or %es_readonly or %es_left or %ws_hscroll or %ws_vscroll or %ws_tabstop or %es_multiline, %ws_ex_clientedge
                control send hform1&,%idd_form1_textraw,%wm_setfont,getstockobject(%ansi_fixed_font),%true
                control add button, hform1&,  %idd_form1_butprevfig,  "&prev.", 200, 42, 34, 14, _
                    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
                control add button, hform1&,  %idd_form1_butnextfig,  "&next", 200, 62, 34, 14, _
                    %ws_child or %ws_visible or %bs_pushbutton or %ws_tabstop or %ws_disabled
                control set color hform1&,%idd_form1_labelgraphwindow ,0,rgb(255,255,255)
                control set color hform1&,%idd_form1_textraw ,0,rgb(255,255,255)
                control set color hform1&,%idd_form1_texthtml ,0,rgb(255,255,255)
                '
                control add "atlaxwin", hform1&, %id_ocx, ocxname, 206, 120, 182, 140, %ws_visible or %ws_child or %ws_border
                '
                ' create a virtual window
                getclientrect getdlgitem(hform1&, %idd_form1_labelgraphwindow), rc
                hdc = getdc(getdlgitem(hform1&, %idd_form1_labelgraphwindow))
                memdc = createcompatibledc(hdc)
                hbit = createcompatiblebitmap(hdc, rc.nright, rc.nbottom)
                selectobject memdc, hbit
                selectobject memdc, getstockobject(%white_brush)
                patblt memdc, 0, 0, rc.nright, rc.nbottom, %patcopy
                '
                outmade& = %false ' start with output flag set to false.
                '
                dialog show modeless hform1&, call form1_dlgproc
                '
                while getmessage(umsg, %null, 0, 0)
                    ' pass keyboard messages to the ancestor
                    ' returns 0 if the message was not processed, nonzero if it was
                    if sendmessage(hocx, %wm_forwardmsg, 0, varptr(umsg)) = 0 then
                       if isdialogmessage(hform1&, umsg) = %false then
                          translatemessage umsg
                          dispatchmessage umsg
                       end if
                    end if
                wend
                '
                deletedc memdc
                deleteobject hbit
                '
                atlaxwinterm   ' uninitializes atl
                set oocx = nothing
                '
            end function
            ------------------




            [this message has been edited by erik christensen (edited may 01, 2005).]

            Comment

            Working...
            X