Vba
Módulo estándar
'*************** Code Start *************************************************** ' Purpose : draw a Snowman on an Access report ' specify center top coordinate and height ' optionally set colors for snowman, hat, buttons, eye, and outline ' USES Circle and Line ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. ' bas_Draw_Snowman_s4p '------------------------------------------------------------------------------ ' Global variables '------------------------------------------------------------------------------ 'comment if defined elsewhere Public Const PI As Double = 3.14159 Public Const gZero As Single = 0.0000001 Public Const gColorOrange As Long = 38650 'RGB(250, 150, 0) 'carrot Public Const gColorBrown As Long = 25750 'RGB(150, 100, 0 'stick arms '------------------------------------------------------------------------------ ' Draw_Snowman_s4p ' send report object, top center coordinate and height '------------------------------------------------------------------------------ Public Sub Draw_Snowman_s4p(poReport As Report _ ,pXCenter As Single _ ,pYTop As Single _ ,pYHeight As Single _ ,Optional pnColorSnowman As Variant = vbWhite _ ,Optional pnColorHat As Variant = vbBlack _ ,Optional pnColorButton As Variant = vbBlack _ ,Optional pnColorEye As Variant = vbBlack _ ,Optional pnColorLine As Variant = vbBlack _ ) '221218, 19 s4p 'Draw a Snowman ' measurements in twips On Error GoTo Proc_Err 'PARAMETERs ' poReport is the Report object ' pXCenter is x-coordinate of Snowman center ' pYTop is y-coordinate of Snowman top ' pYHeight is Snowman height '(Optional) -- long integer color values ' defined as Variant so they can be null ' pnColorSnowman Default is white ' pnColorHat Default is black ' pnColorButton Default is black ' pnColorEye Default is black ' pnColorLine Default is black If IsNull(pnColorSnowman) Then pnColorSnowman = vbWhite If IsNull(pnColorHat) Then pnColorHat = vbBlack If IsNull(pnColorButton) Then pnColorButton = vbBlack If IsNull(pnColorEye) Then pnColorEye = vbBlack If IsNull(pnColorLine) Then pnColorLine = vbBlack 'lots of variables since there are lots of objects Dim X As Single,Y As Single _ ,x1 As Single,y1 As Single _ ,x2 As Single,y2 As Single _ ,yBottomMiddle As Single _ ,yBellyMiddle As Single _ ,yHeadMiddle As Single _ ,sgRadiusBottom As Single _ ,sgRadiusBelly As Single _ ,sgRadiusHead As Single _ ,sgRadiusButton As Single _ ,sgRadiusEye As Single _ ,sgRadiusSmile As Single _ ,sgRadiusHat As Single _ ,sgRadiusCarrot As Single _ ,sgAngleCarrot1 As Single _ ,sgAngleCarrot2 As Single _ ,sgAngleSmile1 As Single _ ,sgAngleSmile2 As Single _ ,sgAngleArm As Single _ ,sgAngleFinger As Single _ ,sgAngle As Single Dim sgLenArm As Single _ ,sgLenFinger As Single _ ,sgWidthFinger As Single _ ,sgWidthScarf As Single _ ,iArm As Integer _ ,iFinger As Integer '----------------------------- customize as desired sgRadiusBottom = pYHeight * 0.25 'bottom ball sgRadiusBelly = pYHeight * 0.2 'belly ball sgRadiusButton = sgRadiusBelly / 12 sgRadiusHead = pYHeight * 0.15 'head ball sgRadiusEye = sgRadiusHead / 8 sgRadiusCarrot = sgRadiusHead * 0.6 sgAngleCarrot1 = gZero sgAngleCarrot2 = PI / 12 sgRadiusSmile = sgRadiusHead * 0.6 sgAngleSmile1 = PI * 1.3 sgAngleSmile2 = PI * 1.7 '----------------------------- With poReport .ScaleMode = 1 'twips .DrawWidth = 1 'pixel .FillStyle = 0 'Opaque 'bottom ball yBottomMiddle = Y + pYHeight - sgRadiusBottom .FillColor = pnColorSnowman 'outline is black poReport.Circle (pXCenter,yBottomMiddle),sgRadiusBottom _ ,pnColorLine,,,0.85 'belly ball - middle yBellyMiddle = Y + pYHeight / 2 .FillColor = pnColorSnowman 'outline is black poReport.Circle (pXCenter,yBellyMiddle),sgRadiusBelly _ ,pnColorLine,,,0.85 'head ball - top yHeadMiddle = Y + pYHeight * 0.25 .FillColor = pnColorSnowman 'outline is black poReport.Circle (pXCenter,yHeadMiddle),sgRadiusHead _ ,pnColorLine 'eyes Y = yHeadMiddle - sgRadiusHead * 0.1 'left eye X = pXCenter - sgRadiusHead / 3 .FillColor = pnColorEye poReport.Circle (X,Y),sgRadiusEye,pnColorEye 'right eye X = pXCenter + sgRadiusHead / 4 poReport.Circle (X,Y),sgRadiusEye,pnColorEye 'smile .DrawWidth = sgRadiusEye / 16 poReport.Circle (pXCenter,Y) _ ,sgRadiusSmile,vbBlack _ ,sgAngleSmile1,sgAngleSmile2 'carrot nose .DrawWidth = 1 X = pXCenter - Cos(sgAngleCarrot1) * sgRadiusCarrot Y = yHeadMiddle + sgRadiusHead / 5 .FillColor = gColorOrange 'negative angles are just indicators to fill poReport.Circle (X,Y) _ ,sgRadiusCarrot,gColorOrange _ ,-sgAngleCarrot1,-sgAngleCarrot2 'hat brim Y = yHeadMiddle - sgRadiusHead * 0.6 .FillColor = pnColorHat poReport.Circle (pXCenter,Y),sgRadiusBelly,pnColorHat _ ,,,0.2 ' hat barrel x1 = pXCenter - sgRadiusHead * 0.8 x2 = pXCenter + sgRadiusHead * 0.8 y1 = pYTop y2 = pYTop + sgRadiusHead '* 0.75 poReport.Line (x1,y1)-(x2,y2),pnColorHat,BF 'buttons Y = yBellyMiddle .FillColor = pnColorButton poReport.Circle (pXCenter,yBellyMiddle) _ ,sgRadiusButton,pnColorButton 'top Y = yBellyMiddle - sgRadiusBelly / 3 poReport.Circle (pXCenter,Y),sgRadiusButton,pnColorButton 'bottom Y = yBellyMiddle + sgRadiusBelly / 3 poReport.Circle (pXCenter,Y),sgRadiusButton,pnColorButton 'lower bottom Y = Y + sgRadiusBelly / 3 poReport.Circle (pXCenter,Y),sgRadiusButton,pnColorButton '--------- arms For iArm = 1 To 2 'arm angle ' x1,y1 at shoulder If iArm = 1 Then sgAngleArm = 7 * PI / 8 x1 = pXCenter - Cos(PI / 4) * sgRadiusBelly / 0.85 y1 = yBellyMiddle - (Sin(PI / 4) * sgRadiusBelly * 0.5) sgLenArm = sgRadiusBelly * 0.8 Else ' start higher sgAngleArm = PI / 3 x1 = pXCenter + Cos(PI / 3) * sgRadiusBelly * 1.5 y1 = yBellyMiddle - (Sin(PI / 3) * sgRadiusBelly * 0.5) sgLenArm = sgRadiusBelly End If 'at wrist x2 = x1 + Cos(sgAngleArm) * sgLenArm y2 = y1 - Sin(sgAngleArm) * sgLenArm .DrawWidth = sgRadiusButton / 6 poReport.Line (x1,y1)-(x2,y2),gColorBrown '--------- fingers 'palm of hand X = x2 Y = y2 For iFinger = 1 To 4 If iFinger = 1 Then 'thumb up sgAngleFinger = sgAngleArm - PI / 2 _ + (PI * (iArm - 1)) sgWidthFinger = sgRadiusButton / 8 sgLenFinger = sgRadiusBelly / 6 ElseIf iFinger = 2 Then 'index finger sgAngleFinger = sgAngleArm - PI / 12 _ + IIf(iArm = 1,0,PI / 4) sgWidthFinger = sgRadiusButton / 12 sgLenFinger = sgRadiusBelly / 3 Else sgAngleFinger = sgAngleFinger _ + (PI / 6) * IIf(iArm = 1,1,-1) End If If iFinger = 4 Then 'shorter pinkie sgLenFinger = sgLenFinger * 0.75 End If If iFinger = 1 Then x2 = X + Cos(sgAngleFinger) * sgLenFinger y2 = Y - Sin(sgAngleFinger) * sgLenFinger Else x2 = X + Cos(sgAngleFinger) * sgLenFinger y2 = Y - Sin(sgAngleFinger) * sgLenFinger End If .DrawWidth = sgWidthFinger poReport.Line (X,Y)-(x2,y2),gColorBrown Next iFinger Next iArm End With Proc_Exit: On Error GoTo 0 Exit Sub Proc_Err: MsgBox Err.Description _ ,, "ERROR " & Err.Number _ & " Draw_Snowman_s4p" Resume Proc_Exit Resume End Sub '*************** Code End *****************************************************
Ir arriba
rpt_Muñeco de nieve_Detalle_Muestra
Informe de código subyacente para dibujar un muñeco de nieve según los colores de estado.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_Snowman_Detail_Sample ' calls Draw_Snowman_s4p ' draw a snowman with colors ' defined in a table ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ '------------------------------------------------------------------------------ ' Detail_Format '------------------------------------------------------------------------------ Private Sub Detail_Format(Cancel As Integer,FormatCount As Integer) '221216 crystal 'draw Snowman in the detail section of a report ' using colors specified (or not) in a table 'CALLs ' Draw_Snowman_s4p Dim X As Single,Y As Single _ ,sgHeight As Single With Me .ScaleMode = 1 'twips ' height for drawing sgHeight = 1.3 * 1440 'inch to twip 'X center X = 1.5 * 1440 '1.5 inch 'top Y = .ScaleTop ' Call Draw_Snowman_s4p ' get color values from the record. Null will get default. Call Draw_Snowman_s4p(Me,X,Y,sgHeight _ ,.ColrSnowman,.ColrSHat,.ColrButton,.ColrEye,.ColrLine) End With End Sub '*************** Code End *****************************************************
Ir arriba
rpt_Página_muñeco de nieve
Informe de código subyacente para dibujar un muñeco de nieve predeterminado en una página.
'*************** Code Start CBR *********************************************** ' Purpose : code behind rpt_Snowmans_Page ' calls Draw_Snowman_s4p ' draw a Snowman on a page ' Author : crystal (strive4peace) ' Code List: www.msaccessgurus.com/code.htm ' This code: ' LICENSE : ' You may freely use and share this code, but not sell it. ' Keep attribution. Mark your changes. Use at your own risk. '------------------------------------------------------------------------------ ' Report_Page '------------------------------------------------------------------------------ Private Sub Report_Page() '221216 crystal 'draw a default snowman on the page 'CALLs ' Draw_Snowman_s4p Dim X As Single,Y As Single _ ,dx As Single,dy As Single _ With Me .ScaleMode = 1 'twips 'width and height for drawing dx = .ScaleWidth dy = .ScaleHeight - .PageFooterSection.Height 'left - center X = .ScaleLeft + dx / 2 'top Y = .ScaleTop End With 'Call Draw_Snowman_s4p Call Draw_Snowman_s4p(Me,X,Y,dy) End Sub '*************** Code End *****************************************************
‘ El código se generó con colores utilizando el complemento gratuito Color Code para Access.
