网络收藏

如题

推荐阅读

看看这个如何:  
  新建一个控件,贴上这些代码  
  option   explicit  
   
  ***[enumerations]***************************************************************************************************  
  public   enum   enuorientation  
          orhorizontal   =   0  
          orvertical   =   1  
  end   enum  
   
  public   enum   enuscalemode  
          smtwips   =   0  
          smpixels   =   1  
          smmilimeters   =   2  
          sminches   =   3  
  end   enum  
   
  public   enum   enuborderstyle  
          bsnoborder   =   0  
          bssingle   =   1  
  end   enum  
   
  ***[default   constants]******************************************************************************************************  
  private   const   mvar_def_orientation   as   long   =   orhorizontal  
  private   const   mvar_def_borderstyle   as   long   =   bsnoborder  
  private   const   mvar_def_scalemode   as   long   =   smtwips  
  private   const   mvar_def_mousetrackingon   as   boolean   =   false  
  private   const   mvar_def_startvalue   as   long   =   0  
   
   
  ***[shared   variables]******************************************************************************************************  
  private   mvarorientation   as   long  
  private   mvarborderstyle   as   long  
  private   mvarscalemode   as   long  
  private   mvarmousetrackingon   as   boolean  
  private   mvarstartvalue   as   long  
   
   
  ***[storage   variables]******************************************************************************************************  
  private   mvarscale   as   long  
   
  ***[events]*********************************************************************************************************  
  public   event   scalemodechanged(mode   as   enuscalemode)  
  public   event   hoovervalue(value   as   long)  
  public   event   click(button   as   integer,   shift   as   integer,   value   as   long)  
  public   event   resize()  
   
  ***[properties]*****************************************************************************************************  
  public   property   get   orientation()   as   enuorientation  
          orientation   =   mvarorientation  
  end   property  
   
  public   property   let   orientation(byval   value   as   enuorientation)  
          mvarorientation   =   value  
          rendercontrol  
          propertychanged   "orientation"  
  end   property  
   
  public   property   get   startvalue()   as   long  
          startvalue   =   mvarstartvalue  
  end   property  
   
  public   property   let   startvalue(byval   value   as   long)  
          mvarstartvalue   =   value  
          rendercontrol  
          propertychanged   "startvalue"  
  end   property  
   
  public   property   get   borderstyle()   as   enuborderstyle  
          borderstyle   =   mvarborderstyle  
  end   property  
   
  public   property   let   borderstyle(byval   value   as   enuborderstyle)  
          mvarborderstyle   =   value  
          usercontrol.borderstyle   =   mvarborderstyle  
          propertychanged   "borderstyle"  
  end   property  
   
  public   property   get   scalemode()   as   enuscalemode  
          scalemode   =   mvarscalemode  
  end   property  
   
  public   property   let   scalemode(byval   value   as   enuscalemode)  
          dim   i   as   long  
           
          mvarscalemode   =   value  
           
          set   scaling  
          select   case   mvarscalemode  
                  case   smtwips  
                          mvarscale   =   1000  
                  case   smpixels  
                          mvarscale   =   screen.twipsperpixelx   *   100  
                  case   smmilimeters  
                          mvarscale   =   570  
                  case   sminches  
                          mvarscale   =   1440  
          end   select  
           
          for   i   =   0   to   3  
                  mnuscalemode(i).checked   =   false  
          next   i  
          mnuscalemode(value).checked   =   true  
           
          rendercontrol  
          propertychanged   "scalemode"  
          raiseevent   scalemodechanged(value)  
  end   property  
   
  public   property   get   forecolor()   as   ole_color  
          forecolor   =   usercontrol.forecolor  
  end   property  
   
  public   property   let   forecolor(byval   new_forecolor   as   ole_color)  
          usercontrol.forecolor()   =   new_forecolor  
          rendercontrol  
          propertychanged   "forecolor"  
  end   property  
   
  public   property   get   backcolor()   as   ole_color  
          backcolor   =   usercontrol.backcolor  
  end   property  
   
  public   property   let   backcolor(byval   new_backcolor   as   ole_color)  
          usercontrol.backcolor()   =   new_backcolor  
          rendercontrol  
          propertychanged   "backcolor"  
  end   property  
   
  public   property   get   mousetrackingon()   as   boolean  
          mousetrackingon   =   mvarmousetrackingon  
  end   property  
   
  public   property   let   mousetrackingon(byval   value   as   boolean)  
          mvarmousetrackingon   =   value  
          propertychanged   "mousetrackingon"  
  end   property  
   
   
  private   sub   usercontrol_readproperties(propbag   as   propertybag)  
          mvarorientation   =   propbag.readproperty("orientation",   mvar_def_orientation)  
          mvarstartvalue   =   propbag.readproperty("startvalue",   mvar_def_startvalue)  
          borderstyle   =   propbag.readproperty("borderstyle",   mvar_def_borderstyle)  
          mvarmousetrackingon   =   propbag.readproperty("mousetrackingon",   mvar_def_mousetrackingon)  
          scalemode   =   propbag.readproperty("scalemode",   mvar_def_scalemode)  
          usercontrol.forecolor   =   propbag.readproperty("forecolor",   &h80000012)  
          usercontrol.backcolor   =   propbag.readproperty("backcolor",   &h80000005)  
          rendercontrol  
  end   sub  
   
 

private   sub   usercontrol_writeproperties(propbag   as   propertybag)  
          call   propbag.writeproperty("orientation",   mvarorientation,   mvar_def_orientation)  
          call   propbag.writeproperty("startvalue",   mvarstartvalue,   mvar_def_startvalue)  
          call   propbag.writeproperty("borderstyle",   mvarborderstyle,   mvar_def_borderstyle)  
          call   propbag.writeproperty("mousetrackingon",   mvarmousetrackingon,   mvar_def_mousetrackingon)  
          call   propbag.writeproperty("scalemode",   mvarscalemode,   mvar_def_scalemode)  
          call   propbag.writeproperty("forecolor",   usercontrol.forecolor,   &h80000012)  
          call   propbag.writeproperty("backcolor",   usercontrol.backcolor,   &h80000005)  
  end   sub  
   
   
  private   sub   usercontrol_initialize()  
          scalemode   =   smtwips  
  end   sub  
   
  private   sub   usercontrol_resize()  
          rendercontrol  
          raiseevent   resize  
  end   sub  
   
  private   sub   usercontrol_mousedown(button   as   integer,   shift   as   integer,   x   as   single,   y   as   single)  
          if   button   =   vbrightbutton   then  
                  popupmenu   mnuscalemodemenu  
          end   if  
  end   sub  
   
  private   sub   usercontrol_mousemove(button   as   integer,   shift   as   integer,   x   as   single,   y   as   single)  
          rendertrackline   x,   y  
          raiseevent   hoovervalue(calculatevalue(x,   y))  
  end   sub  
   
  private   sub   usercontrol_mouseup(button   as   integer,   shift   as   integer,   x   as   single,   y   as   single)  
          raiseevent   click(button,   shift,   calculatevalue(x,   y))  
  end   sub  
   
  private   function   calculatevalue(x   as   single,   y   as   single)   as   long  
          dim   myvalue   as   long  
          select   case   mvarorientation  
          case   orhorizontal  
                  myvalue   =   int(x   /   (mvarscale   /   10))  
          case   orvertical  
                  myvalue   =   int(y   /   (mvarscale   /   10))  
          end   select  
          myvalue   =   myvalue   +   mvarstartvalue   *   10  
          select   case   mvarscalemode  
                  case   smtwips  
                          myvalue   =   myvalue   *   100  
                  case   smpixels  
                          myvalue   =   myvalue   *   10  
                  case   smmilimeters  
                          myvalue   =   myvalue  
                  case   sminches  
                          myvalue   =   int(myvalue   /   10)  
          end   select  
           
          calculatevalue   =   myvalue  
  end   function  
   
  public   sub   rendertrackline(x   as   single,   y   as   single)  
          if   mvarmousetrackingon   =   true   then  
                  rendercontrol  
                  optionaly   render   mouse   tracking   line  
                  select   case   orientation  
                  case   orhorizontal  
                          line   (x,   0)-(x,   scaleheight)  
                  case   orvertical  
                          line   (0,   y)-(scalewidth,   y)  
                  end   select  
          end   if  
  end   sub  
   
  private   sub   mnuscalemode_click(index   as   integer)  
          scalemode   =   index  
          rendercontrol  
  end   sub  
   
  public   sub   refresh()  
          rendercontrol  
  end   sub  
   
  private   sub   rendercontrol()  
          dim   mysmallscale   as   long  
          dim   myvalue   as   string  
          dim   i   as   long  
          dim   j   as   long  
          mysmallscale   =   mvarscale   /   10  
           
          cls  
          select   case   mvarorientation  
          case   orhorizontal  
                  for   j   =   0   to   width   step   mvarscale  
                          draw   big   line  
                          line   (j,   0)-(j,   scaleheight)  
                          print   value  
                          myvalue   =   j   /   mvarscale  
                          currenty   =   0  
                          currentx   =   currentx   +   30  
                          print   myvalue   +   startvalue  
                          draw   small   lines  
                          for   i   =   j   +   mysmallscale   to   j   +   mvarscale   -   mysmallscale   step   mysmallscale  
                                  if   i   =   j   +   mvarscale   /   2   then  
                                          line   (i,   scaleheight   /   2)-(i,   scaleheight)  
                                  else  
                                          line   (i,   scaleheight   -   scaleheight   /   3)-(i,   scaleheight)  
                                  end   if  
                          next   i  
                  next   j  
                   
          case   orvertical  
                  for   j   =   0   to   height   step   mvarscale  
                          draw   big   line  
                          line   (0,   j)-(scalewidth,   j)  
                          print   value  
                          myvalue   =   j   /   mvarscale  
                          currenty   =   currenty   +   30  
                          currentx   =   0  
                          print   myvalue   +   startvalue  
                          draw   small   lines  
                          for   i   =   j   +   mysmallscale   to   j   +   mvarscale   -   mysmallscale   step   mysmallscale  
                                  if   i   =   j   +   mvarscale   /   2   then  
                                          line   (scalewidth   /   2,   i)-(scalewidth,   i)  
                                  else  
                                          line   (scalewidth   -   scalewidth   /   3,   i)-(scalewidth,   i)  
                                  end   if  
                          next   i  
                  next   j  
                   
          end   select  
           
           
  end   sub  
   
 

mnuscalemodemenu少了

up