ok

es algo parecido en 3d

porque en 3d seria de mas grosor
un ejemplo en 3d

gracias

ok

he puesto el valor relativo en los 4 cajos


Valor relativo (porcentaje): (cstr(v1) & "%")


muchas gracias

perfecto justo lo que necesitaba


muchisimas gracias serapis

lo que quiero es poner los valores numericos que hay en los textbox osea text2,text3,text4,text5,en cada particion del grafico circular que sean visibles

lo del indice no hace falta, ya lo he solucionado


y perdona si no me expreso bien



gracias

he mejorado el codigo del grafico ahora introduzco los datos fijos y los lee

solo quisiera poner el porcentaje en el grafico circular

el codigo es el siguiente

 
 
 
Option Explicit
Private Type departamento
 d As Date
 x As Double
 y As Double
 z As Double
 w As Double
 End Type
 
Dim dpto As departamento
Dim NumRecs As Long
 
Private Sub Command1_Click()
'Grafico
DrawPie
End Sub
 
 
 
Private Sub DrawPie()
Const PI As Double = 3.14159265359
Dim x1 As Double, y1 As Double, z1 As Double, w1 As Double
Dim x As Double, y As Double, z As Double, w As Double
Dim r As Double, midx As Double, midy As Double
Dim sum As Double
'Text1.Text = Format$(Date, "dd/mm/yyyy")
  Picture2.Cls
 
  Picture2.FillStyle = 0
 
  x1 = Val(Text2.Text)
  y1 = Val(Text3.Text)
  z1 = Val(Text4.Text)
  w1 = Val(Text5.Text)
 
  sum = x1 + y1 + z1 + w1
 
  x = x1 / sum
  y = y1 / sum
  z = z1 / sum
  w = w1 / sum
 
  midx = Picture2.Width / 2
  midy = Picture2.Height / 2
 
  r = Picture2.Width / 2 - 300
 
  If x <> 0 And y <> 0 And z <> 0 Then
 
  Picture2.FillColor = vbRed
  Picture2.Circle (midx, midy), r, , -2 * PI, -2 * PI * x, 2 / 3
  Picture2.FillColor = vbYellow
  Picture2.Circle (midx, midy), r, , -2 * PI * x, -2 * PI * (x + y), 2 / 3
  Picture2.FillColor = vbBlue
  Picture2.Circle (midx, midy), r, , -2 * PI * (x + y), -2 * PI * (x + y + z), 2 / 3
  Picture2.FillColor = vbGreen
  Picture2.Circle (midx, midy), r, , -2 * PI * (x + y + z), -2 * PI, 2 / 3
  End If
 
End Sub
 
Private Sub Command2_Click()
'Guardar
 With dpto
      .d = Text1.Text
      .x = Val(Text2.Text)
      .y = Val(Text3.Text)
      .z = Val(Text4.Text)
      .w = Val(Text5.Text)
    End With
 
    NumRecs = 1
    Open App.Path & "\PieData.dat" For Random As #1 Len = Len(dpto)
      Put #1, 1, NumRecs
      Put #1, NumRecs + 1, dpto
    Close #1
End Sub
 
Private Sub Command3_Click()
'Leer
 
 
 
 
'If FileLen(App.Path & "\PieData.dat") > 60 Then
    Open App.Path & "\PieData.dat" For Random As #1 Len = Len(dpto)
      Get #1, 1, NumRecs
      Get #1, NumRecs + 1, dpto
 
      With dpto
       Text1.Text = .d
       Text2.Text = Val(.x)
       Text3.Text = Val(.y)
       Text4.Text = Val(.z)
       Text5.Text = Val(.w)
End With
 
 
 
 
    Close #1
    DrawPie
  'End If
End Sub
 
Private Sub Command4_Click()
End
End Sub
 
Private Sub Command5_Click()
Picture2.Cls
Text2.SetFocus
End Sub
 
 
 
 
Private Sub Form_Load()
Text1.Text = Format$(Date, "dd/mm/yyyy")
End Sub
 
 
 
 
 

Gracias

estoy haciendo un pequeño programa con el cual hay unos datos fijos y quisiera poner esos datos en el grafico circular hay cuatro datos pero hay un quinto dato que falta dibujar  que es la variable z1 en el grafico y poner el dato en el grafico.

en el programa faltaria controlar el indice de introducir los datos que empezara por 1,2,3,4,5, etc


el ejemplo que tengo hasta ahora es el siguiente:

 
 
Option Explicit
Private Type departamento
 d As Date
 w As Double
 x As Double
 y As Double
 z As Double
 zl As Double
 End Type
 
Dim dpto As departamento
Dim NumRecs As Long
 
Private Sub Command1_Click()
'Grafico
DrawPie
End Sub
 
Private Sub DrawPiePiece(lColor As Long, ByVal fStart As Double, ByVal fEnd As Double)
  Const PI As Double = 3.14159265359
  Const CircleEnd As Double = -2 * PI
  Dim dStart As Double
  Dim dEnd As Double
 
  Picture2.FillColor = lColor
  Picture2.FillStyle = 0
  dStart = fStart * (CircleEnd / 100)
  dEnd = fEnd * (CircleEnd / 100)
  Picture2.Circle (170, 150), 100, , dStart, dEnd
End Sub
 
Private Sub DrawPie()
  Dim Disp As Single, Alq As Single, i As Byte, Vt As Integer, Ang1 As Single, Ang2 As Single
 
  Picture2.Cls
 
  Picture2.AutoRedraw = True
  Picture2.BackColor = &H8000000E
  Picture2.ScaleMode = vbPixels
 
 
  Dim xx As Double
  Dim yy As Double
  Dim zz As Double
  Dim uu As Double
 
 
  With dpto
    If .w = 0 Then MsgBox "No hay registros para" & DateTime.Date & "para ser mostrado"
        Text1.Text = .d
        If .w > 0 Then
        xx = (.x * 100) / .w
        yy = xx + (.y * 100) / .w
        zz = yy + (.z * 100) / .w
        uu = zz + (.zl * 100) / .w
 
        Call DrawPiePiece(QBColor(1), 0.001, xx)
        Call DrawPiePiece(QBColor(6), xx, yy)
        Call DrawPiePiece(QBColor(3), yy, zz)
        Call DrawPiePiece(QBColor(5), zz, uu)
    End If
 
  End With
End Sub
 
Private Sub Command2_Click()
'Guardar
 With dpto
      .d = Date
      .w = 650
      .x = 301
      .y = 39
      .z = 109
      .zl = 201
    End With
 
    NumRecs = 1
    Open App.Path & "\PieData.dat" For Random As #1 Len = 64
      Put #1, 1, NumRecs
      Put #1, NumRecs + 1, dpto
    Close #1
End Sub
 
Private Sub Command3_Click()
'Leer
If FileLen(App.Path & "\PieData.dat") > 60 Then
    Open App.Path & "\PieData.dat" For Random As #1 Len = 64
      Get #1, 1, NumRecs
      Get #1, NumRecs + 1, dpto
    Close #1
    DrawPie
  End If
End Sub
 
Private Sub Command4_Click()
End
End Sub
 
Private Sub Command5_Click()
Picture2.Cls
End Sub
 
 
 
 

gracias

Hola Serapis

ahora si que suma

 
txtTotalFactura.Text = cstr(regx.total)
 
 

muchas gracias

Hola Serapis

se que soy muy pesado en esto de la programacion ahora son detalles

ahora me faltaria hacer la suma una vez que lees la compra, hacer el total de la suma


gracias

Hola Serapis


ya lo he corregido funciona correctamente

me habia puesto un poco nervioso, pero depues con mas tranquilidad lo he podido solucionar


muchas gracias

Hola Serapis


He conseguido buscar con el texbox pero tiene que ir con el listado de  listlotes

si carga con listlotes busca si no carga no busca


hay alguna manera de hacer la busqueda sin listlotes

 
Private Sub Command1_Click()
'Buscar
Dim Id As Integer
 
    If (NumRegsLotes > 0) Then '  If (LisLotes.ListCount > 0) Then   ' si hay registros en la facturación...
        If (IsNumeric(txtNumeroFactura.Text)) Then    ' si el textbox tiene un número válido
            Id = CInt(txtNumeroFactura.Text)               ' el textbox es quien indica ahora el numero de factura
            If (Id <= NumRegsLotes) Then
                Call PosicionarRegLote(Id)  ' Call PosicionarRegLote(LisLotes.ListIndex + 1)          ' allí se resta 1.
                Get #CanalLote, , RegX
                IdLote = RegX.IdPedido
                Call ListarCompraDelLote(RegX.Index, RegX.Cantidad)
                'txtFactura.Text = RegCompraToString(Reg)
                Exit Sub
            End If
        End If
    End If
 
    ' Si el botón está siempre activado... lo ideal es que esté activo solo si el número de factura es válido.
    'txtFactura.Text = ""
    Call MsgBox("Número de factura no reconocido. Debe haber facturas y el número de factura ser mayor que 0 y menor que el número de registros actuales")
End Sub
 
 
 
 
 
' Abre y carga el fichero de facturación. También abre el fichero de productos comprados (solo carga los productos asociados al primer lote en el listado).
' NOTA: No establecer la propiedad SORTED a TRUE, en los listados, ya que entonces el añadido sería ordenado y no al final.
Private Function ListarFacturacion(ByRef Ruta1 As String, ByRef Ruta2 As String) As Boolean
  '...
    Dim k As Integer
 
    Call CerrarFacturacion
 
    If ((Abrir(Ruta1, CanalLote) = True) And (Abrir(Ruta2, CanalProducto) = True)) Then
        Get #CanalLote, 1, NumRegsLotes
        Get #CanalLote, , AutoIncLote
 
        Get #CanalProducto, 1, NumRegsProds
        Get #CanalProducto, , AutoIncProducto
 
        If (NumRegsLotes > 0) Then
            With LisLotes
                .Clear
 
                Call PosicionarRegLote(1)       ' allí se resta 1
                For k = 0 To NumRegsLotes - 1
                    Get #CanalLote, , RegX
                    Call .AddItem(RegCompraToString(RegX))
                    .ItemData(k) = RegX.IdPedido
 
                    If (RegX.MetodoDePago = MetodosDePago.PAGO_AL_CONTADO) Then
                        TotalContado = (TotalContado + RegX.Total)
                    Else
                        TotalCredito = (TotalCredito + RegX.Total)
                    End If
                Next
 
                Call ShowTotales
 
                ' Ahora si se quiere puede leerse de nuevo el primer registro para transferirlo a los textbox...
                .ListIndex = 0 ' para ello delegamos en el código que pondremos al listbox...
            End With
        End If
 
        mnuLotes(0).Enabled = True
        ListarFacturacion = True
    End If
 
 
 
 
 
 
    ' Remplazar/eliminar las líneas aqui comentadas:
    If (NumRegsLotes > 0) Then
            'With LisLotes
             '   .Clear
 
                Call PosicionarRegLote(1)       ' allí se resta 1
                For k = 0 To NumRegsLotes - 1
                    Get #CanalLote, , RegX
             '       Call .AddItem(RegCompraToString(RegX))
              '      .ItemData(k) = RegX.IdPedido
 
                    If (RegX.MetodoDePago = MetodosDePago.PAGO_AL_CONTADO) Then
                        TotalContado = (TotalContado + RegX.Total)
                    Else
                        TotalCredito = (TotalCredito + RegX.Total)
                    End If
                Next
 
                Call ShowTotales
 
                ' <---- Ahora si se quiere puede leerse de nuevo el primer registro para transferirlo a los textbox...
             '   .ListIndex = 0 ' para ello delegamos en el código que pondremos al listbox...
            'End With
 
    ' Y añadir estas dos en esta posición:  <---- Ahora si se quiere puede leerse de nuevo el primer registro para transferirlo
             txtNumeroFactura.Text = "1"
             Call Command1_Click
   End If
End Function
 
 
' Guarda el registro del lote. Cada lote puede componerse de varios registros de artículso comprados,
Friend Sub GuardarCompra(ByRef Reg As RegLote, ByVal Productos As Integer)
    NumRegsLotes = (NumRegsLotes + 1)
    AutoIncLote = (AutoIncLote + 1)
 
    With Reg
        .IdPedido = AutoIncLote                             ' Completa los datos del registro que (mejor) procede hacer aquí.
        .Cantidad = Productos
        .FechaCompra = DateTime.Now
        .Index = (NumRegsProds - .Cantidad)
 
        If (.MetodoDePago = PAGO_AL_CONTADO) Then
            TotalContado = (TotalContado + .Total)
        Else
            TotalCredito = (TotalCredito + .Total)
        End If
        Call ShowTotales                                    ' Actualiza los valores totales.
    End With
 
    Call PosicionarRegLote(NumRegsLotes)                    ' Posiciona el cursor de escritura al final del fichero.
    Put #CanalLote, , Reg                                   ' Guarda el registro.
    'With LisLotes
       ' Call .AddItem(RegCompraToString(Reg))               ' También lo añade al listado.
        '.ItemData(.ListCount - 1) = AutoIncLote
   ' End With
 
    txtNumeroFactura.Text = CStr(Reg.IdPedido)
     txtFactura.Text = RegCompraToString(Reg)
     Call Command1_Click
 
 
    Put #CanalLote, 1, NumRegsLotes                         ' Guarda la cantidad de registros
    Put #CanalLote, , AutoIncLote                           ' Guarda el valor de autoincrmeento (es un valor único).
 
    Put #CanalProducto, 1, NumRegsProds
    Put #CanalProducto, , AutoIncProducto                   ' Guarda el valor de autoincrmeento (es un valor único).
 
   'LisLotes.ListIndex = (LisLotes.ListCount - 1)           ' Fuerza a listar los productos comprados en este lote. 
 
 
 
 
 
 
 
 
 
 
 

gracias