form1.frm

条形码的设计与打印

         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Left            =   30
      TabIndex        =   13
      Top             =   4920
      Width           =   6375
   End
   Begin VB.Menu mnucp 
      Caption         =   "Copy Image"
      Visible         =   0   'False
      Begin VB.Menu mnuCopyImage1 
         Caption         =   "将条码保存到剪切板"
      End
      Begin VB.Menu mnuSaveImage1 
         Caption         =   "条码保存为..."
      End
   End
   Begin VB.Menu mnucp1 
      Caption         =   "Copy Image2"
      Visible         =   0   'False
      Begin VB.Menu mnuCopyImage2 
         Caption         =   "将条码保存到剪切板"
      End
      Begin VB.Menu mnuSaveImage2 
         Caption         =   "条码保存为..."
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit

Dim Target As Object
Dim LastSave As String '上次保存目录
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub cboBarSize_Click()
    '改变条形码的大小
    Picture2.ScaleMode = 3
    Picture1.ScaleMode = 3
    Select Case cboBarSize.ListIndex
        Case 0
            Picture2.Height = Picture2.Height * (1.4 * 40 / Picture2.ScaleHeight)
            Picture2.FontSize = 8
        Case 1
            Picture2.Height = Picture2.Height * (2.4 * 40 / Picture2.ScaleHeight)
            Picture2.FontSize = 10
        Case 2
            Picture2.Height = Picture2.Height * (3 * 40 / Picture2.ScaleHeight)
            Picture2.FontSize = 14
    End Select
    Call Text1_Change
End Sub

Private Sub cboTextStyle_Click()
    Text1_Change
End Sub

Private Sub checkBarCaption_Click()
    If checkBarCaption.Value = 1 Then
        checkBarCaption.Caption = "显示文字"
        chkTextAlignment.Visible = True
    Else
        checkBarCaption.Caption = "不显示文字"
        chkTextAlignment.Value = 0
        chkTextAlignment.Visible = False
    End If
End Sub

Private Sub chkBar128_Click()
    If chkBar128.Value = 0 Then
        Picture1.Visible = False
    Else
        Picture1.Visible = True
    End If
End Sub

Private Sub chkBar39_Click()
    If chkBar39.Value = 0 Then
        Picture2.Visible = False
    Else
        Picture2.Visible = True
    End If
End Sub

Private Sub chkTextAlignment_Click()
    If chkTextAlignment.Value = 1 Then
        chkTextAlignment.Caption = "文字置底"
    Else
        chkTextAlignment.Caption = "文字置顶"
    End If
End Sub

Private Sub printBar128()
    '打印128型条码
    Dim Dl As Long
    Dim MinWidth  As Long
    Picture1.Cls
    
    Dim RT_VAL As RET_VAL
    
    With bar
        .crBack = RGB(255, 255, 255)
        .crFore = RGB(0, 0, 0)
        .lalign = 1     '文本对其方式
        .lExtra = 4     '条码和文字间距离
        .lheight = 40   '条码高度
        .lLeft = 20     '条码左边位置
        .lR1 = 1        '大小条码比例
        .lR2 = 1        '
        .lRetHeight = 0 '返回条码实际高度
        .lRetWidth = 0  '返回条码实际宽度
        .lRotation = 0  '条码旋转角度，0表示0度，1表示90度
        .lShowCheck = 1 '是否显示检查数位
        '文本的增粗，倾斜，下划线等
        .lstyle = cboTextStyle.ListIndex + 1
        .lTop = 1       '条码顶端位置
        '文本显示在顶(1)端还是底端(2)
        .ltxtdisp = chkTextAlignment.Value + 1
        'Width of thin bar in pixel
        .lWidth = cboBarSize.ListIndex + 1
        .nsize = 10     '条码字体大小
        .szAdDigit = "" '
        .szBarCaption = IIf(checkBarCaption.Value, Text1.Text, "")
        .szDigit = ""   '
        .szReadText = Text1.Text
        .szSymbology = 16
        '文字颜色
        .TextColor = RGB(255, 0, 0)
        '字体名称
        .tiFaceName = "Courier New"
    End With
    
    Set Target = Picture1
    Dl = Special_128b(bar, Target.hDc)
    
    If Dl <> 0 Then MsgBox ErrSpecial_128bMessage(Dl)
End Sub

Private Sub Form_KeyDown(keycode As Integer, Shift As Integer)
    If keycode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
    cboBarSize.ListIndex = 1
    cboTextStyle.ListIndex = 0
End Sub

Private Sub mnuCopyImage1_Click()
    '将条码1保存到剪切板
    pCopyToClipBoard Picture1
End Sub

Private Sub mnuCopyImage2_Click()
    '将条码2保存到剪切板
     pCopyToClipBoard Picture2
End Sub

Private Sub mnuSaveImage1_Click()
    '调用FileSaving，保存128型条码
     FileSave Picture1
     If ChkExecute.Value = 1 Then
        '显示导出文件
        ShellExecute Me.hwnd, "open", CDialog.FileName, 0&, LastSave, vbNormalFocus
     End If
End Sub

Private Sub mnuSaveImage2_Click()
    '调用FileSaving，保存39型条码
    FileSave Picture2
    If ChkExecute.Value = 1 Then
        '显示导出文件
        ShellExecute Me.hwnd, "open", CDialog.FileName, 0&, LastSave, vbNormalFocus
    End If
    
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 And Text1 <> "" Then
        PopupMenu mnucp
    End If
End Sub

Private Sub Picture2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 And Text1 <> "" Then
        PopupMenu mnucp1
    End If
End Sub

Private Sub Text1_Change()
    '文字改变时重绘条码
    Dim MinWidth, pw
    If chkBar128.Value = 1 Then
        printBar128
    End If
    If chkBar39.Value = 1 Then
        Call DrawBarcode(Text1, Picture2)
    End If
End Sub
Sub pCopyToClipBoard(ByVal PictureBox As Object)
    '将条码导入剪切板
    PictureBox.Picture = PictureBox.Image
    Clipboard.Clear
    Clipboard.SetData PictureBox.Image, 2
End Sub


Sub FileSave(Picbox As PictureBox)
    '将条码导入适当格式的文件中
    Dim sName, RetVal, retSave
    Dim ObjGifImg As GIF
    Screen.MousePointer = 11
    
    CDialog.FilterIndex = 1
    If LastSave <> "" Then
        CDialog.InitDir = LastSave
    Else
        CDialog.InitDir = App.Path & "\ExportedImages"
    End If
    
On Error GoTo ErrHandler
    CDialog.FileName = Picbox.Name
    CDialog.CancelError = True
    CDialog.Flags = cdlOFNOverwritePrompt + cdlOFNNoReadOnlyReturn
    CDialog.Filter = "Bitmaps (*.bmp)|*.bmp|Gif (*.gif)|*.gif|Transparent Gif (*.gif)|*.gif"
    CDialog.ShowSave
    '获取文件夹
    retSave = InStrRev(CDialog.FileName, "\")
    LastSave = Mid(CDialog.FileName, 1, retSave)
    DoEvents
    
    Picbox.Picture = Picbox.Image
    Select Case CDialog.FilterIndex
      Case 1: '保存为位图文件
                SavePicture Picbox.Picture, CDialog.FileName
      Case 2: '保存为GIF文件
                Set ObjGifImg = New GIF
                ObjGifImg.SaveGIF Picbox.Image, CDialog.FileName, Picbox.hDc, False, Picbox.Point(0, 0)
                Set ObjGifImg = Nothing
      Case 3: '保存为透明的GIF文件
                Set ObjGifImg = New GIF
                ObjGifImg.SaveGIF Picbox.Image, CDialog.FileName, Picbox.hDc, True, Picbox.Point(0, 0)
                Set ObjGifImg = Nothing
    End Select

    Screen.MousePointer = 0
    Exit Sub
ErrHandler:

    If Err.Number = 32755 Then '获取保存文件对话框的CancelError
        Screen.MousePointer = 0
        Exit Sub
    Else
        If Err.Number <> 0 Then MsgBox "保存文件错误: " & Err.Number & " - " & Err.Description
        Screen.MousePointer = 0
    End If
    
End Sub