Nhờ viết code in tiêu đề (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

langtuchungtinh360

Thành viên đã dừng hoạt động
Tham gia
7/10/13
Bài viết
1,062
Được thích
334
Em có viết 1 form trong file đính kèm. tới bước viết để chọn vùng in tiêu đề thì bí lù
rất mong được mọi người giúp đỡ viết hộ mình, nếu có thể rất mong các góp ý về code để code có thể ngắn lại (Vì code hiện dài thoòng)
 

File đính kèm

Em có viết 1 form trong file đính kèm. tới bước viết để chọn vùng in tiêu đề thì bí lù
rất mong được mọi người giúp đỡ viết hộ mình, nếu có thể rất mong các góp ý về code để code có thể ngắn lại (Vì code hiện dài thoòng)
đợi chờ chả ai giúp +-+-+-+
đã xong
Mã:
Dim DaChon As Byte
Private Sub ApplyPageSetup_Click()
    Dim k As Byte
    Dim Tren As Single, Duoi As Single, Trai As Single, Phai As Single
If DonVi.Value = "cm" Then
    If Len(LeTren.Value) = 0 Then Tren = 1 Else Tren = Replace(LeTren, ".", ",")
    If Len(LeDuoi.Value) = 0 Then Duoi = 1 Else Duoi = Replace(LeDuoi, ".", ",")
    If Len(LeTrai.Value) = 0 Then Trai = 4 Else Trai = Replace(LeTrai, ".", ",")
    If Len(LePhai.Value) = 0 Then Phai = 1 Else Phai = Replace(LePhai, ".", ",")
Else
    If Len(LeTren.Value) = 0 Then Tren = 0.3 Else Tren = Replace(LeTren, ".", ",")
    If Len(LeDuoi.Value) = 0 Then Duoi = 0.3 Else Duoi = Replace(LeDuoi, ".", ",")
    If Len(LeTrai.Value) = 0 Then Trai = 0.9 Else Trai = Replace(LeTrai, ".", ",")
    If Len(LePhai.Value) = 0 Then Phai = 0.3 Else Phai = Replace(LePhai, ".", ",")
End If
k = 0
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then k = k + 1
Next
    Dim Tam As String
Tam = Me.KhoGiay.Caption
Application.ScreenUpdating = False
Application.PrintCommunication = False
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then
        Me.PhanTram.Width = 58
        Me.Bar.Width = Me.Bar.Width + (150 / k)
        If Round(100 * Me.Bar.Width / 150, 1) >= 100 Then _
                Me.PhanTram.Width = 0 _
                Else _
                : Me.PhanTram.Caption = Round(100 * Me.Bar.Width / 150, 1) & "%"
        'Me.PhanTram.Caption = Round(100 * Me.Bar.Width / 150, 1) & "%"
        DoEvents
        With Worksheets(ListBox1.List(i)).PageSetup
            If DonVi.Value = "inch" Then
                .LeftMargin = Application.InchesToPoints(Trai)
                .RightMargin = Application.InchesToPoints(LPhai)
                .TopMargin = Application.InchesToPoints(Tren)
                .BottomMargin = Application.InchesToPoints(Duoi)
            Else
                .LeftMargin = Application.CentimetersToPoints(Trai)
                .RightMargin = Application.CentimetersToPoints(Phai)
                .TopMargin = Application.CentimetersToPoints(Tren)
                .BottomMargin = Application.CentimetersToPoints(Duoi)
            End If
            [COLOR=#ff0000]If Len(InTieuDe.Value) = 0 Then GoTo BoQua
            Sh = Mid(InTieuDe, 1, Application.WorksheetFunction.Find("!", InTieuDe))
            Vug = Mid(InTieuDe, Application.WorksheetFunction.Find("!", InTieuDe) + 1, Len(InTieuDe) - Len(Sh))
            Arr = "QWERTYUIOPASDFGHJKLZXCVBNMqwertyuiopasdfghjklzxcvbnm!"
            For x = 0 To Len(Arr) - 1
                Vug = Replace(Vug, Mid(Arr, x + 1, 1), "")
            Next x
            VungInTieuDe = Sh & Replace(Vug, "$$", "$")
            .PrintTitleRows = VungInTieuDe
            InTieuDe = VungInTieuDe
BoQua:
             [/COLOR]
            If InNhuHienThi.Value = True Then
                .PrintComments = xlPrintInPlace
            Else
                .PrintComments = xlPrintNoComments
            End If
            tmp = KhoGiay.Caption
            .PaperSize = Switch(tmp = "A3", xlPaperA3, tmp = "A4", xlPaperA4, tmp = "A5", xlPaperA5, _
                    tmp = "A6", 70, tmp = "B4", 127, tmp = "B5", 128, tmp = "", xlPaperLetter)
            If Ngang.Value Then
                .Orientation = xlLandscape
            Else
                .Orientation = xlPortrait
            End If
        End With
    End If
Next i
Me.Bar.Width = 0
Me.PhanTram.Width = 0
Me.KhoGiay.Caption = Tam
DaChon = 0
Application.PrintCommunication = True
Application.ScreenUpdating = True
End Sub
Private Sub ChuThich()
    NutHienThi.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & _
            ChrW(7875) & " hi" & ChrW(7875) & "n th" & ChrW(7883) & " c" & ChrW(225) & "c trang t" & ChrW(237) & "nh " _
            & ChrW(273) & ChrW(432) & ChrW(7907) & "c ch" & ChrW(7885) & "n"
    NutAn.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & _
            ChrW(7875) & " " & ChrW(7849) & "n c" & ChrW(225) & "c trang t" & ChrW(237) & "nh " & ChrW(273) & _
            ChrW(432) & ChrW(7907) & "c ch" & ChrW(7885) & "n"
    NutSieuAn.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & _
            ChrW(7875) & " si" & ChrW(234) & "u " & ChrW(7849) & "n c" & ChrW(225) & "c trang t" & ChrW(237) & "nh " _
            & ChrW(273) & ChrW(432) & ChrW(7907) & "c ch" & ChrW(7885) & "n" & ChrW(10) & " (C" & _
            ChrW(225) & "c Sheets n" & ChrW(224) & "y s" & ChrW(7869) & " kh" & ChrW(244) & _
            "ng th" & ChrW(7875) & " d" & ChrW(249) & "ng l" & ChrW(7879) & "nh Unhide " & _
            ChrW(273) & ChrW(7875) & " hi" & ChrW(7875) & "n th" & ChrW(7883) & " l" & ChrW(7841) _
            & "i " & ChrW(273) & ChrW(432) & ChrW(7907) & "c)"
    NutKhoiPhuc.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & ChrW(7875) & " kh" & _
            ChrW(244) & "i bi" & ChrW(234) & "n b" & ChrW(7843) & "n nh" & ChrW(432) & " ban " & ChrW(273) & ChrW(7847) & "u"
    NutDiDen.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & ChrW(7875) & _
            " " & ChrW(273) & "i " & ChrW(273) & ChrW(7871) & "n trang t" & ChrW(237) & "nh " & _
            ChrW(273) & ChrW(227) & " ch" & ChrW(7885) & "n"
    Me.ListBox1.ControlTipText = "Nh" & ChrW(7845) & "n gi" & ChrW(7919) & _
            "a phím Ctrl + Click chu" & ChrW(7897) & "t " & ChrW(273) & ChrW(7875) & " ch" & _
            ChrW(7885) & "n nhi" & ChrW(7873) & "u " & ChrW(273) & ChrW(7889) & "i t" & ChrW(432) _
            & ChrW(7907) & "ng"
    Me.LamMoi.ControlTipText = "Nh" & ChrW(7845) & "n v" & ChrW(224) & "o " & ChrW(273) & _
            ChrW(7875) & " l" & ChrW(224) & "m m" & ChrW(7899) & "i danh s" & ChrW(225) & "ch"
    Me.XemTatca.ControlTipText = "Ch" & ChrW(7885) & "n " & ChrW(273) & _
            ChrW(7875) & " xem c" & ChrW(225) & "c trang t" & ChrW(237) & "nh c" & ChrW(243) & _
            " trong file hi" & ChrW(7879) & "n h" & ChrW(224) & "nh"
    Me.XemSheetHien.ControlTipText = "Ch" & ChrW(7885) & "n " & ChrW(273) & ChrW(7875) & _
            " xem c" & ChrW(225) & "c trang t" & ChrW(237) & "nh " & ChrW(273) & "ang kh" & _
            ChrW(244) & "ng b" & ChrW(7883) & " " & ChrW(7849) & "n"
    Me.XemSheetAn.ControlTipText = "Ch" & ChrW(7885) & "n " & ChrW(273) _
            & ChrW(7875) & " xem c" & ChrW(225) & "c trang t" & ChrW(237) & "nh b" & ChrW(7883) & _
            " " & ChrW(7849) & "n"
    Me.XemSheetSieuAn.ControlTipText = "Ch" & ChrW(7885) & "n " & _
            ChrW(273) & ChrW(7875) & " xem c" & ChrW(225) & "c trang t" & ChrW(237) & "nh b" & _
            ChrW(7883) & " " & ChrW(7849) & "n (Kh" & ChrW(244) & "ng th" & ChrW(7875) & " b" & _
            ChrW(7887) & " " & ChrW(7849) & "n b" & ChrW(7857) & "ng l" & ChrW(7879) & "nh th" & _
            ChrW(244) & "ng th" & ChrW(432) & ChrW(7901) & "ng)"
End Sub
Private Sub DangBangTinh_Change()
    ListBox1.Clear
    If DangBangTinh.Value = "  Bi" & ChrW(234) & "n b" & ChrW(7843) & "n" Then 'neu chon xem bien ban
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 2) = "BB" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    ElseIf DangBangTinh.Value = "  Ph" & ChrW(7909) & " l" & ChrW(7909) & "c" Then 'neu chon xem phu luc
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 3) = "Phu" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    ElseIf DangBangTinh.Value = "  S" & ChrW(7893) & " " & ChrW(273) & "o" Then 'neu chon xem so do
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 3) = "SoD" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    ElseIf DangBangTinh.Value = "  Phi" & ChrW(7871) & "u c" & ChrW(244) & "ng t" & ChrW(225) & "c" Then 'neu chon xem phieu cong tac
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 3) = "Phi" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    ElseIf DangBangTinh.Value = "  S" & ChrW(7889) & " li" & ChrW(7879) & "u" Then 'neu chon xem so lieu
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 3) = "SoL" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    ElseIf DangBangTinh.Value = "  Thông tin" Then 'neu chon xem thong tin
        For Each Sheet In Worksheets
            i = i + 1
            If Left$(Sheets(i).Name, 2) <> "BB" And _
                    Left$(Sheets(i).Name, 3) <> "Phu" And _
                    Left$(Sheets(i).Name, 3) <> "SoD" And _
                    Left$(Sheets(i).Name, 3) <> "Phi" And _
                    Left$(Sheets(i).Name, 3) <> "SoL" Then ListBox1.AddItem Application.Sheets(i).Name
        Next
    End If
End Sub
Private Sub DonVi_Change()
    LeTrai = ""
    LePhai = ""
    LeTren = ""
    LeDuoi = ""
End Sub
Private Sub InTieuDe_DropButtonClick()
    DaChon = 1
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Worksheets(ListBox1.List(i)).Visible = xlSheetVisible
            Worksheets(ListBox1.List(i)).Select
            Exit Sub
        End If
    Next i
End Sub
Private Sub KhoGiay1_Click()
    KhoGiayKhac = ""
End Sub
Private Sub KhoGiayKhac_Change()
    KhoGiay.Caption = KhoGiayKhac.Value
End Sub
Private Sub KhoGiay_Click()
    KhoGiayKhac = ""
End Sub
Private Sub KhoiPhucNgatTrang_Click()
End Sub
Private Sub LamMoi_Click()
    DangBangTinh.Value = ""
    If XemTatca.Value Then
        Call RunTatca
    ElseIf XemSheetHien.Value Then
        Call RunSheetHien
    ElseIf XemSheetAn.Value Then
        Call RunSheetAn
    ElseIf XemSheetSieuAn.Value Then
        Call RunSheetSieuAn
    End If
End Sub
Private Sub ListBox1_Change()
    DaChon = 0
End Sub
Private Sub ListBox1_MouseMove(ByVal Button As Integer, _
            ByVal Shift As Integer, _
            ByVal x As Single, _
            ByVal y As Single)
    HookControlScroll ListBox1
    Dim SoChia As Single
    If NutAnHien.Caption = "<" Then
        For i = 0 To ListBox1.ListCount - 1
            If ListBox1.Selected(i) = True Then
                With Worksheets(ListBox1.List(i)).PageSetup
                    If .Orientation = xlLandscape Then Ngang.Value = True Else Doc.Value = True
                    If .PaperSize = xlPaperA3 Then KhoGiay.Caption = "A3" Else KhoGiay.Caption = "A4"
                    tmp = .PaperSize
                    KhoGiay.Caption = Switch(tmp = 8, "A3", tmp = 9, "A4", tmp = 11, "A5", _
                            tmp = "70", "A6", tmp = "127", "B4", tmp = "128", "B5", tmp = 1, "")
                    If .PrintComments = xlPrintInPlace Then InNhuHienThi.Value = True Else InNhuHienThi.Value = False
                    If DonVi.Value = "inch" Then SoChia = 72 Else SoChia = 28.34
                    LeTren.Value = Round(.TopMargin / SoChia, 2)
                    LeDuoi.Value = Round(.BottomMargin / SoChia, 2)
                    LeTrai.Value = Round(.LeftMargin / SoChia, 2)
                    LePhai.Value = Round(.RightMargin / SoChia, 2)
                    If DaChon = 0 Then InTieuDe.Value = .PrintTitleRows
                End With
                Exit Sub
            End If
        Next i
    Else
    End If
End Sub
Private Sub NutAnHien_Click()
    If NutAnHien.Caption = ">" Then
        NutAnHien.Caption = "<"
        Me.Width = 483
        Me.Bar.Width = 0
        Me.PhanTram.Width = 0
    Else
        NutAnHien.Caption = ">"
        Me.Width = 316
    End If
End Sub
Private Sub NutAn_Click()
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then Worksheets(ListBox1.List(i)).Visible = _
                xlSheetHidden
    Next i
    Call XoaItem
    If SelectAll.Value = True Then
        Worksheets("Menus").Visible = xlSheetVisible
        Worksheets(ActiveSheet.Name).Visible = xlSheetVeryHidden
    End If
    SelectAll.Value = False
End Sub
Private Sub NutDiDen_Click()
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Worksheets(ListBox1.List(i)).Visible = xlSheetVisible
            Worksheets(ListBox1.List(i)).Select
            Exit Sub
        End If
    Next i
End Sub
Private Sub NutHienThi_Click()
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then Worksheets(ListBox1.List(i)).Visible = _
                xlSheetVisible
    Next i
    Call XoaItem
    SelectAll.Value = False
End Sub
Private Sub NutHuybo_Click()
    On Error Resume Next
    Unload Me
End Sub
Private Sub NutKhoiPhuc_Click()
    Dim x As Byte
    Dim i As Byte
    Dim k As Integer
    Dim OK As Byte
    OK = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            If OK = 1 Then GoTo TiepTuc
            x = UniBox("Thông báo", "B" & ChrW(7841) & "n ch" & ChrW(7855) & _
                    "c ch" & ChrW(7855) & "n mu" & ChrW(7889) & "n kh" & _
                    ChrW(244) & "i ph" & ChrW(7909) & "c l" & ChrW(7841) & _
                    "i?" & ChrW(10) & "T" & ChrW(7845) & "t c" & ChrW(7843) & _
                    " thay " & ChrW(273) & ChrW(7893) & "i s" & ChrW(7869) & _
                    " " & ChrW(273) & ChrW(432) & ChrW(7907) & "c kh" & _
                    ChrW(244) & "i ph" & ChrW(7909) & "c l" & ChrW(7841) & _
                    "i nh" & ChrW(432) & " ban " & ChrW(273) & ChrW(7847) & "u." _
                    , 1, 2)
            If x <> 1 Then Exit Sub Else OK = 1
        End If
    Next i
TiepTuc:
    On Error Resume Next
    k = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then
            Application.Run ListBox1.List(i)
            k = k + 1
        End If
    Next i
    If (ListBox1.ListCount > 0) And (k = 0) Then UniBox _
            "Thông báo", "B" & ChrW(7841) & "n ch" & ChrW(432) & _
            "a ch" & ChrW(7885) & "n Bi" & ChrW(234) & "n b" & _
            ChrW(7843) & "n c" & ChrW(7847) & "n kh" & ChrW(244) & _
            "i ph" & ChrW(7909) & "c", 0, 1
    Call XoaItem
    UniBox "Thông báo", "Bi" & ChrW(234) & "n b" & ChrW(7843) & "n " & ChrW(273) & ChrW(227) & " kh" & ChrW(244) & "i ph" & ChrW(7909) & "c l" & ChrW(7841) & "i ban " & ChrW(273) & ChrW(7847) & "u!", 0, 4
    SelectAll.Value = False
End Sub
Private Sub NutSieuAn_Click()
    On Error Resume Next
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i) = True Then Worksheets(ListBox1.List(i)).Visible = _
                xlSheetVeryHidden
    Next i
    Call XoaItem
    If SelectAll.Value = True Then
        Worksheets("Menus").Visible = xlSheetVisible
        Worksheets(ActiveSheet.Name).Visible = xlSheetVeryHidden
    End If
    SelectAll.Value = False
End Sub
Private Sub RunSheetAn()
    On Error Resume Next
    ListBox1.Clear
    For Each Sheet In Worksheets
        i = i + 1
        If (Application.Sheets(i).Visible = xlSheetHidden) Then ListBox1.AddItem _
                Application.Sheets(i).Name
    Next
    SelectAll.Value = False
End Sub
Private Sub RunSheetHien()
    On Error Resume Next
    ListBox1.Clear
    For Each Sheet In Worksheets
        i = i + 1
        If (Application.Sheets(i).Visible = xlSheetVisible) Then ListBox1.AddItem _
                Application.Sheets(i).Name
    Next
    SelectAll.Value = False
End Sub
Private Sub RunSheetSieuAn()
    On Error Resume Next
    ListBox1.Clear
    For Each Sheet In Worksheets
        i = i + 1
        If (Application.Sheets(i).Visible = xlSheetVeryHidden) Then ListBox1.AddItem _
                Application.Sheets(i).Name
    Next
    SelectAll.Value = False
End Sub
Private Sub RunTatca()
    On Error Resume Next
    ListBox1.Clear
    For Each Sheet In Worksheets
        i = i + 1
        If (Application.Sheets(i).Visible = xlSheetVisible) Or _
                (Application.Sheets(i).Visible = xlSheetVeryHidden) Or _
                (Application.Sheets(i).Visible = xlSheetHidden) Then _
                ListBox1.AddItem Application.Sheets(i).Name
    Next
    SelectAll.Value = False
End Sub
Private Sub SelectAll_Click()
    'bo chon/ chon tat ca
    If SelectAll.Value = True Then
        For i = 0 To ListBox1.ListCount - 1
            ListBox1.Selected(i) = True
        Next i
    End If
    If SelectAll.Value = False Then
        For i = 0 To ListBox1.ListCount - 1
            ListBox1.Selected(i) = False
        Next i
    End If
End Sub
Private Sub UserForm_Initialize()
    On Error Resume Next
    Me.Caption = ""
    i = 0
    For Each Sheet In Worksheets
        i = i + 1
        If (Application.Sheets(i).Visible = xlSheetVisible) Or _
                (Application.Sheets(i).Visible = xlSheetVeryHidden) Or _
                (Application.Sheets(i).Visible = xlSheetHidden) Then ListBox1.AddItem _
                Application.Sheets(i).Name
    Next
    Dim Arr()
    Arr = Array("  Thông tin", "  Bi" & ChrW(234) & "n b" & ChrW(7843) & "n", _
            "  Ph" & ChrW(7909) & " l" & ChrW(7909) & "c", _
            "  S" & ChrW(7893) & " " & ChrW(273) & "o", _
            "  Phi" & ChrW(7871) & "u c" & ChrW(244) & "ng t" & ChrW(225) & "c", _
            "  S" & ChrW(7889) & " li" & ChrW(7879) & "u")
    Me.DangBangTinh.List = Arr
    Dim Arr2()
    Arr2 = Array("cm", "inch")
    Me.DonVi.List = Arr2
    Arr3 = Array("A3", "A4", "A5", "A6", "B4", "B5", "")
    Me.KhoGiayKhac.List = Arr3
    Call ChuThich
    DaChon = 0
    Me.Width = 316
    Me.Frame2.Caption = ChrW(272) & ChrW(7883) & "nh d" & ChrW(7841) & "ng"
End Sub
Private Sub UserForm_Terminate()
    UnhookControlScroll
End Sub
Private Sub XemSheetAn_Click()
    RunSheetAn
End Sub
Private Sub XemSheetHien_Click()
    RunSheetHien
End Sub
Private Sub XemSheetSieuAn_Click()
    RunSheetSieuAn
End Sub
Private Sub XemTatca_Click()
    RunTatca
End Sub
Private Sub XoaItem()
    Dim counter As Integer
    counter = 0
    For i = 0 To ListBox1.ListCount - 1
        If ListBox1.Selected(i - counter) Then
            ListBox1.RemoveItem (i - counter)
            counter = counter + 1
        End If
    Next i
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0

Bài viết mới nhất

Back
Top Bottom